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

...
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