Function ArrAutofilterNew(ByRef arr, ParamArray args() As Variant) As Variant    ' Новая версия функции ArrAutofilter, от января 2021 года.  © ExcelVBA.ru
    ' Получает по ссылке массив ARR для фильтрации
    ' и список критериев фильтрации в формате "3=маска текста" (номер столбца, "=", искомое значение)
    ' Возвращает двумерный массив с подходящими строками
    
    On Error Resume Next
    ArrAutofilterNew = False ' возвращаемое значение в случае ошибки
    If UBound(args) = -1 Then Debug.Print "Array filtering error: filters required": Exit Function
    ReDim Filters(1 To UBound(args) + 1, 1 To 2)
 
    Dim i&, ColumnToCheck&, FiltersCount&, j&, ro&, RowsCount&:  Err.Clear: i& = UBound(arr, 2)
    If Err.Number > 0 Then Debug.Print "Array filtering error: two dimensional array required": Exit Function
 
    For i& = LBound(args) To UBound(args)    ' перебираем все параметры фильтрации
        If Not IsMissing(args(i&)) Then
            If args(i&) Like "#*=*" Then ' распознаем параметры фильтрации
                FiltersCount& = FiltersCount& + 1
                Filters(FiltersCount&, 1) = Val(Split(args(i&), "=")(0)) ' столбец массива
                Filters(FiltersCount&, 2) = Split(args(i&), "=", 2)(1) ' маска для значения
            Else ' неверно заданный фильтр
                Debug.Print "ArrAutofilterNew error: invalid filter «" & args(i&) & "»"
            End If
        End If
    Next i&
    If FiltersCount& = 0 Then Debug.Print "Array filtering error: all filters are empty": Exit Function
 
    ReDim arrCheck(LBound(arr, 1) To UBound(arr, 1)) As Boolean ' для результатов проверки
    For i = LBound(arr, 1) To UBound(arr, 1)    ' перебираем все строки массива, и проверяем их
        arrCheck(i) = True
        For j& = 1 To FiltersCount&    ' перебираем все параметры фильтрации
            If Not (arr(i, Filters(j&, 1)) Like Filters(j&, 2)) Then arrCheck(i) = False: Exit For
        Next j&
        RowsCount& = RowsCount& - arrCheck(i) ' увеличиваем счётчик подходящих строк на 1
    Next i
    If RowsCount& = 0 Then Exit Function ' выход, если нет ни одной подходящей строки в массиве
    
    ReDim newarr(1 To RowsCount&, LBound(arr, 2) To UBound(arr, 2)) ' формируем новый массив
    For i = LBound(arr, 1) To UBound(arr, 1)    ' снова перебираем все строки массива
        If arrCheck(i) Then ' если строка ранее помечена как подходящая
            ro& = ro& + 1 ' вычисляем номер строки в новом массиве
            For j = LBound(arr, 2) To UBound(arr, 2)
                newarr(ro&, j) = arr(i, j) ' заполняем массив значениями из исходного
            Next j
        End If
    Next i
    ArrAutofilterNew = newarr ' возвращаем результат
    Erase arrCheck
End Function

If arrCheck(i) Then ' если строка ранее помечена как подходящая
            ro& = ro& + 1 ' вычисляем номер строки в новом массиве
...

Me.Service_macros.List = Array("восс-е исходных значений ДИ", "восс-е контекст. меню листа", "визуал-я 1 строки прихода", "отображение скрытых имен")

Private Sub Service_macros_Change()
    ad = Array(Func_RecNM, Func_RecCM, Func_RecViz, Func_ShowImen)(Service_macros.ListIndex)
End Sub

Private Sub Service_macros_Change()
    Select Case Service_macros.ListIndex
         Case 0: ad = Func_RecNM
         Case 1: ad = Func_RecCM
         Case 2: ad = Func_RecViz
         Case 3: ad = Func_ShowImen
     End Select
End Sub

f =  45962 '"декабрь" '
r = [Dt].Find(f, , , , , xlPrevious).Row
MsgBox r

 For i = 1 To UBound(xF)
    n = Calc_NR(dicNum, xF(i, 1) & "|" & xF(i, 4))
    dicData.Item(Join(Array(n, xF(i, 6), xF(i, 3)), "|")) = xF(i, 2)
 Next i

Function Calc_NR(dicNum As Object, key As String) As Long 'расчет нумерации реестра
    If dicNum.Exists(key) Then
        Calc_NR = Calc_NR + 1
    Else
        dicNum.Item(key) = 1: Calc_NR = 1
    End If
End Function

dicData.Item(Join(Array(n, xF(i, 6)...

dicData.Item(Join(Array(Calc_NR, xF(i, 6)...

        For i = 1 To 2
            If Not dicMail.Exists(Key) Then
                dicMail.Item(Key) = Cells(i, 1).Value & ".pdf"
            Else:
                dicMail.Item(Key) = Array(dicMail.Item(Key), Cells(i, 1).Value & ".pdf")
            End If
        Next i
ad = Func_SendMailCDO(dicMail)

Function Func_SendMailCDO(dicMail As Object) 'отправка на e-mail покупателя
    Dim objCDOCnf As Object, objCDOMsg As Object, att As Variant, k As Variant
        Const CDO_Cnf = "http://schemas.microsoft.com/cdo/configuration/"
        Set objCDOCnf = CreateObject("CDO.Configuration") 'назначаем конфигурацию CDO
        
            With objCDOCnf.Fields
...
                .Item(CDO_Cnf & "sendusername") = "login@mail.ru" 'учетная запись на сервере
                .Item(CDO_Cnf & "sendpassword") = "pass" 'пароль к почтовому аккаунту
                .Update
            End With
                    
            On Error Resume Next
            For Each k In dicMail.keys
                Set objCDOMsg = CreateObject("CDO.Message") 'создаем сообщение
                With objCDOMsg
...
                    .Subject = "Копии документов" 'тема письма

For Each att In dicMail.Item(k)
         .Attachments.Add ThisWorkbook.Path & "\" & att
         Kill ThisWorkbook.Path & "\" & att
Next att
       .Send

Function test(CaseWord As Byte, Surname As String, Optional Name As String, Optional Patronymic As String) As String
    tmp = Mid(Array(Surname, Name, Patronymic)(i), 1, Len(Array(Surname, Name, Patronymic)(i)) - 1)
    'склонение фамилии
    t1 = tmp
    i = i + 1
    'склонение имени
    t2 = tmp & 123
End Function

    Dim v_RegExp As Object, s As String
        Set v_RegExp = CreateObject("VBScript.RegExp")
            s = "2;2;222;202:5;155545;25;6:3;13;13;89"
            v_RegExp.Pattern = ":"
            v_RegExp.Global = True
            f = v_RegExp.Execute(s).Item(0).FirstIndex '11
            
            ff = InStr(s, ":5;") - 1 '11

    For Each n In ActiveWorkbook.Names 'перерасчет диапазона для диспетчера имен
      If Mid(Split(n.Value, "!")(0), 3, Len(Split(n.Value, "!")(0)) - 3) = "КП арендаторов"  Then n.Value = Left(n.Value, InStrRev(n.Value, "$")) & Cells(Rows.Count, 1).End(xlUp).Row
    Next n

For Each n In Filter(ActiveWorkbook.Names, "КП арендаторов")

Range("A4:D9").Value = Range("A1:D2").FormulaR1C1

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