Dim dicData As Object, i As Long, Data As Variant, Data2 As Variant
    Set dicData = CreateObject("Scripting.Dictionary"): dicData.CompareMode = 1
        
        For i = 1 To 5
            dicData.Item(Cells(i, 1)) = Cells(i, 2)
        Next i
            Data = Filter(dicData.keys, "р", , vbTextCompare)

Dim dicData As Object, key As String, i As Long, kt As Variant
        Set dicData = CreateObject("Scripting.Dictionary"): dicData.CompareMode = 1
                        
            For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
                key = Join(Array(i, Cells(i, 1), Cells(i, 2)), "|")
                dicData.Item(key) = Cells(i, 3)
            Next i

            k = 5 & "|" & 123456 & "|" & 123456
            
            For Each kt In Filter(dicData.keys, Split(k, "|")(2) & "|" & Split(k, "|")(2), , vbTextCompare)
                res = dicData.Item(kt)
            Next kt

            For Each kt In Filter(dicData.keys, "*" & "|" & Split(k, "|")(2), , vbTextCompare)
                sum = sum + dicDataTemp.Item(kt)
            Next kt

 Set dicData = CreateObject("Scripting.Dictionary"): dicData.CompareMode = 1
    x = Range("A1:B" & Cells(Rows.Count, 2).End(xlUp).Row).Value
        For i = 1 To UBound(x)
            dicData.Add x(i, 1), i
        Next i

ss = Application.CountIf(dicData.keys, "??.09.2022")

If Not Dic.exists(t) Then 'если ещё нет ключа
   Set Dic2 = CreateObject("Scripting.Dictionary"): Dic2.CompareMode = 1 'создаём субсловарь
...

For Each k In Filter(dicData.keys,  "|ОК", , 1)
...

Range(cell_close).Interior.Color = 255

    Dim HPB As HPageBreak, rngHPB As Range, sum_page As Double, i As Long, j As Long
        If ActiveSheet.Name = "Остатки на складе" Then 'обязательно условие - указание имени листа, иначе VBA пытается выполнить код на др. листах
            With Sheets("Остатки на складе")
'                If .HPageBreaks.Count > 0 Then
                    Set rngHPB = .HPageBreaks(.HPageBreaks.Count).Location
                    i = 8
                    
                    For Each HPB In ActiveSheet.HPageBreaks
                        j = j + 1
                        Set rngHPB = HPB.Location
                        sum_page = Application.Sum(.Range(.Cells(i, 9), .Cells(HPB.Location.Row - 1, 9)))
                        If sum_page > 0 Then
                            i = HPB.Location.Row
                            .PageSetup.RightFooter = Join(Array("Итого по стр. ", j, Space(1), Format(sum_page, "0.00")))
                            .PrintOut From:=j, To:=j, Copies:=1, Collate:=True
                        Else: Exit Sub
                        End If
                    Next HPB
'                End If
            End With
        End If

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Arr_fuel = Array("бензин", "топливо", "газ")
    For j = 0 To UBound(Arr_fuel)
        If UCase(ActiveCell.Value) Like UCase("*" & Arr_fuel(j) & "*") Then Exit For
    Next j
                    
    If j <= UBound(Arr_fuel) Then
        x = Range("A1:C" & Cells(Rows.Count, 1).End(xlUp).Row).Value
                            
        For i = 1 To UBound(x)
            If UCase(x(i, 1)) Like UCase("*" & Arr_fuel(j) & "*") Then MsgBox "ДА  " & Arr_fuel(j)
        Next i
    Else: MsgBox "НЕТ"
    End If
End Sub

    WS = Range("A2:C" & Cells(Rows.Count, 1).End(xlUp).Row).Value
        For i = UBound(WS) To 1 Step -1
            If WS(i, 1) <= [E2] Then
                MsgBox WS(i, 3): Exit For
            End If
        Next i

Arr_Mem = Array("аренда", "коммерческий") 'первоначальное значение переменной 

ReDim Arr_data(1 To dicData.Count, 1 To 7) 'формирование итогового массива
      For Each k In dicData.keys
          If IsNumeric(Application.Match(dicData.keys()(1), Arr_Mem, 0)) Then
             j = j + 1
             Arr_data(j, 1) = ...
             Arr_data(j, 2) = ...
             ...
          end if
      next k
       .Cells(4, 1).Resize(UBound(Arr_data), 6).Value = Arr_data 'выгрузка
       Arr_Mem = Array("сторонний", "аренда (к)") 'изменение значения переменной                

Sub MakeMenu() 'Добавление пунктов контекстного меню
    Dim NewMenu As CommandBarControl, Item As CommandBarControl, ws As Worksheet, MenuCount As Long, i As Long, Arr_ws As String

    For Each ws In Worksheets
        If ws.Visible = True Then Arr_ws = Join(Array(ws.Name, Arr_ws))
    Next ws
    
    ReDim Cap(1 To UBound(Split(Arr_ws)))
    ReDim Mac(1 To UBound(Split(Arr_ws)))
        For i = 1 To UBound(Split(Arr_ws))
            Cap(i) = Split(Arr_ws)(UBound(Split(Arr_ws)) - i)
            Mac(i) = "Sw_Sh" & i
        Next i

    On Error Resume Next
    Application.CommandBars("Cell").Controls("&Переход на лист").Delete 'Удалить меню, если оно уже существует
    On Error GoTo 0
    
'   Добавление меню
    MenuCount = Application.CommandBars("Cell").Controls.Count
    Set NewMenu = Application.CommandBars("Cell").Controls.Add(Type:=msoControlPopup, Before:=MenuCount, temporary:=True)
    NewMenu.Caption = "&Переход на лист"
    
    For i = 1 To UBound(Split(Arr_ws)) 'Добавление пунктов меню
        Set Item = NewMenu.Controls.Add(Type:=msocontrolbutton, temporary:=True)
        Item.Caption = Cap(i)
        Item.OnAction = Mac(i)
   Next i
End Sub

Sub DeleteMenu() 'Удаление меню перед закрытием
    On Error Resume Next
    Application.CommandBars(1).Controls("Переход на лист").Delete
End Sub 

Sub Sw_Sh1()
   Sheets(1).Activate
End Sub

Sub Sw_Sh2()
   Sheets(2).Activate
End Sub
...

Cap(i) = Split(Arr_ws)(UBound(Split(Arr_ws)) - i)
Mac(i) = Sheets(Split(Arr_ws)(UBound(Split(Arr_ws)) - i)).Activate

Sub Univ()   
     Sheets(wk).Activate
End Sub

.Send

    Set objOle = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=200, Height:=30)
    Set cboCombo = objOle.Object
    cboCombo.BackColor = 255
    
        For i = 1 To 5
            cboCombo.AddItem i
        Next i

...
If IsNumeric(Application.Match(x(i, 1), Arr_opt, 0)) Then
...

If Len(Me.Opt_help.Value) > 0 Then
      Arr_opt = Array("замена", "металлолом", "хоз. нужды")
Else: Arr_opt = Array("")
End If

Function Sort_Array(ByRef x(), n As Long) 'функция сортировки массивов
    Dim st As Long, d As Long, f As Long, u As Long, v As Variant
        If IsArray(x) Then
            f = LBound(x): d = f
            For u = f + 1 To UBound(x)
                If x(u, n) < x(d, n) Then
                    For st = 1 To UBound(x, 2)
                        v = x(d, st): x(d, st) = x(u, st): x(u, st) = v
                    Next st
                        u = d - 1: d = u - 1: If u < f Then d = u: u = f
                End If
                    d = d + 1
            Next u
        End If
End Function

Private Sub Write_mat_AfterUpdate() 'аналог кнопки (сработка по Enter)
    Dim LastRow_r As Long
        On Error Resume Next
        If Len(Me.Consumer.Value) > 0 Then
            If CDbl(Me.Write_mat.Value) <= CDbl(Me.Rest.Value) Then
                With Sheets("Расход")
                    LastRow_r = .Cells(Rows.Count, 2).End(xlUp).Row + 1
                    .Cells(LastRow_r, 1).Value = ActiveCell.Offset(, -5).Value 'дата расхода
 ...
                End With
                    Unload Me
            Else: MsgBox "Вы не можете списать более " & Me.Rest.Value & ActiveCell.Offset(, -1).Value, vbCritical, "Внимание! Превышение остатка": Exit Sub
            End If
            If CDbl(Me.Write_mat.Value) = CDbl(Me.Rest.Value) Then ActiveCell.Interior.Color = &HFF00& 'визуализация полного расхода позиции
        Else
            Me.Consumer.BackColor = &HFF&
            MsgBox "Вы не указали потребителя (поле выделено красным цветом), исправьте", vbInformation, "Внимание!": Exit Sub
    End If
End Sub

           If MsgBox("Вы уверены?", vbCritical + vbYesNo, "Внимание! Подумайте перед ответом") = vbYes Then
                FileName = GetFileName("Укажите файл для импорта", ThisWorkbook.Path) 'запрашиваем имя файла
                If Len(FileName) = 0 Then Exit Sub 'выход, если пользователь отказался от выбора файла
            Else: Exit Sub
            End If

Dim oCDOCnf As Object, oCDOMsg As Object
...
   Set oCDOMsg = CreateObject("CDO.Message")
...
       oCDOMsg.AddAttachment ThisWorkbook.Path & "\" & sFiles

Dim Arr_Count(4)
        Arr_Count(0) = "a"
        Arr_Count(1) = "b"
        Arr_Count(2) = "c"
        Arr_Count(3) = "c"
        Arr_Count(4) = "d"
    MsgBox Application.CountIf([Arr_Count], "c")

Private Sub Workbook_BeforePrint(Cancel As Boolean) 'предпечатная подготовка листа "Формы"
'    Dim b As Boolean
    With ActiveSheet
'        If b = False Then
        If .Name = "Форма" Then 'обязательно условие: указание имени листа, иначе VBA пытается выполнить код на др. листах
            Application.EnableEvents = False
            .Rows("1:30").Copy .Range("A33")
            .Rows("31:32").RowHeight = 6.75
            .Range("A31:G31").Borders(xlEdgeBottom).LineStyle = xlDashDot
            .Range("$A$1:$G$62").PrintOut Copies:=1
            .Rows("31:62").Delete
'            b = True
            Application.EnableEvents = True
'        End If
        End If
    End With
End Sub

Function Get_Text_from_Comment(rCell As Range) 'доступ к информации комментария
    Application.Volatile True
    On Error Resume Next
    Get_Text_from_Comment = rCell.Comment.Text
End Functio

.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:=Chr(36) & Cells(2, i).Address(False, False)           

.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:="=$AE2"