x = Range("A1:J" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    
    For i = 1 To UBound(x) 'расчет номера 1 строки реестра
        If x(i, 1) = "ГНН-0001" And CDate(x(i, 3)) = #1/1/2023# Then Exit For
    Next i
                    
    With Cells(i, 1).Resize(UBound(ArrAutofilterNew(x, "1=" & "ГНН-0001", "3=" & #1/1/2023#)), 10).Interior
    'раскраска ячеек
    End With

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 Each att In dicMail.Item(k)
                        .AddAttachment ThisWorkbook.Path & "\" & att
                        Kill ThisWorkbook.Path & "\" & att
                    Next att

        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

ad= DeclensionFIO(2, CStr(Split([F1])(0)), CStr(Split([F1])(1)), CStr(Split([F1])(2)))

Function DeclensionFIO_Arr(CaseWord As Byte, ParamArray SNP()) As String 
...

ad = DeclensionFIO_Arr(3, Split([F1]))