Форум на данный момент в стадии обновления. Если у Вас возникли проблемы со входом в свою учетную запись - просьба писать на email: info@excel-vba.ru
Цитата: Alexander.V от 13.05.2025, 08:50:08Прошу подсказать варианты решенийНу вот как бы...Подсказать варианты или сделать все с нуля?
'Selection.Copy 'где-то копируем какой-то диапазон
Sub PasteValuesAndComments()
ActiveCell.PasteSpecial Paste:=xlPasteValues 'вставка значений
ActiveCell.PasteSpecial Paste:=xlPasteComments 'вставка примечаний
End Sub
Добавить это в контекстное меню для ячеек можно так:With Application.CommandBars("Cell").Controls.Add(before:=1)
.Caption = "Вставить значения и примечания"
.Style = 2
.OnAction = "'" & ThisWorkbook.Name & "'!PasteValuesAndComments"
End With
Но здесь есть нюанс: пункт будет добавлен столько раз, сколько раз будет вызван этот код. Поэтому лучше сначала проверять наличие такого пункта в меню и удалять его, и только потом добавлять новый. 'добавление в контекстное меню ячеек пункта вставки значений и примечаний
'этот код правильнее вызывать при открытии нужной книги - на событие Workbook_Open(хотя и здесь есть нюансы)
Sub AddButtonToCellMenu()
Dim cbb
Const sBCaption$ = "Вставить значения и примечания"
'ищем пункт в меню и если он уже есть - удаляем, чтобы не было задвоений
On Error Resume Next
Set cbb = Application.CommandBars("Cell").Controls(sBCaption)
If Not cbb Is Nothing Then
cbb.Delete
End If
With Application.CommandBars("Cell").Controls.Add(before:=1)
.Caption = sBCaption
.Style = 2
.OnAction = "'" & ThisWorkbook.Name & "'!PasteValuesAndComments"
End With
End Sub
'
Sub PasteValuesAndComments()
On Error GoTo Err_Handler
ActiveCell.PasteSpecial Paste:=xlPasteValues 'вставка значений
ActiveCell.PasteSpecial Paste:=xlPasteComments 'вставка примечаний
Err_Handler:
If Err.Number = 1004 Then
MsgBox "Буфер обмена пуст!", vbInformation, "https:\\excel-vba.ru"
End If
End Sub
Цитата: Alexander.V от 12.05.2025, 14:02:38У меня похожая задачкаПохожая, но другая.
Windows Registry Editor Version 5.00
[HKEY_CLASSES_ROOT\Excel.Sheet.8.Separate]
@="Microsoft Excel Worksheet (Separate Instance)"
[HKEY_CLASSES_ROOT\Excel.Sheet.8.Separate\shell]
[HKEY_CLASSES_ROOT\Excel.Sheet.8.Separate\shell\open]
[HKEY_CLASSES_ROOT\Excel.Sheet.8.Separate\shell\open\command]
@="\"C:\\Program Files (x86)\\Microsoft Office\\OFFICE11\\EXCEL.EXE\" /x \"%1\""
'dd - это даты. Значит объявлять надо тоже как даты, чтобы сравнение шло в итоге корректно
Function define_stat(ws As String, dd As Date, dta_rng As Range, pls_tank As String, pls_salt, option1 As String, def_ As String)
On Error Resume Next
Dim mass_(100) As Variant
Dim result As Double
j = -1
For Each r In dta_rng
pos = Split(r.Address, "$")
'у объекта Range есть свойства Row и Column, которые отвечают за номер строки и столбца.
' поэтому их и надо ипользовать
If r.Row >= 3 Then
If r.Value = "" Then
rng_fin = CStr(mass_(0)) & ":" & CStr(mass_(j))
'Здесь можно задать дополнительные функции для вывода данных, например Average
If def_ = "max" Then result_ = WorksheetFunction.Max(Sheets(ws).Range(rng_fin))
If def_ = "aver" Then result_ = WorksheetFunction.average(Sheets(ws).Range(rng_fin))
If def_ = "min" Then result_ = WorksheetFunction.Min(Sheets(ws).Range(rng_fin))
'Debug.Print result_
GoTo stp
End If
a = Split(r.Value, " ")
dd_now = CDate(a(0))
If dd_now = dd Then
'явно указываем поиск по значениям и по части ячейки (LookIn и lookat)
w = Sheets(ws).Range(pls_tank & CInt(pos(2))).Find(option1, LookIn:=xlValues, lookat:=xlPart) 'признак резервуаров
If w <> "" Then
j = j + 1
mass_(j) = Sheets(ws).Range(pls_salt & CInt(pos(2))).Address 'столбец, в котором находятся значения солей
'Debug.Print mass_(j)
'Debug.Print j
End If
End If
End If
Next
stp:
define_stat = result_ 'вывод результата функции
End Function