Форум по VBA и MS Office

Sub Макрос()

    Dim sh_src As Worksheet, rng_src As Range, sh_res As Worksheet
    Dim коды_res()
    Dim var, lr As Long, lc As Long, r As Long, i As Long
   
   
    ' Отключение монитора и формул, чтобы ускорить макрос.
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    '1. Присваиваем имена листам, с которыми надо работать.
    Set sh_src = Worksheets("CF_Pos")
    Set sh_res = Worksheets("Accounts")
   
    '2. Подготовка листов.
    '1) Сброс автофильтра.
    If sh_src.AutoFilterMode = True Then
        sh_src.AutoFilter.ShowAllData
        sh_src.AutoFilter.Sort.SortFields.Clear
    End If
    If sh_res.AutoFilterMode = True Then
        sh_res.AutoFilter.ShowAllData
        sh_res.AutoFilter.Sort.SortFields.Clear
    End If
   
    '3. Создание ссылки на столбец A листа-источника до последней строки.
        ' End не ищет в скрытых строках.
    lr = sh_src.Cells(sh_src.Rows.Count, "A").End(xlUp).Row
    Set rng_src = sh_src.Range("A1:A" & lr)
   
    '4. Копирование данных из столбца M в массив.
        ' End не ищет в скрытых строках.
    lr = sh_res.Cells(sh_res.Rows.Count, "M").End(xlUp).Row
    коды_res() = sh_res.Range("M1:M" & lr).Value
   
    '5. Создание проверок данных в виде списка.
    For i = 11 To UBound(коды_res)
   
        '1) Если в столбце T есть проверка данных, то переход на следующую строку.
            ' Делается бессмысленное действие, чтобы узнать, есть проверка данных или нет.
            ' Нормального способа проверить возможности нет.
        On Error Resume Next
        If sh_res.Cells(i, "T").Validation.Type = 1 Then
        End If
        var = Err.number
        On Error GoTo 0
        If var = 0 Then
            GoTo СледующСтрока
        End If
       
        '2) Если в столбце M текст не соответствует шаблону, то
            ' переход на следующую строку.
        If Not коды_res(i, 1) Like "125*AXEL*at prior year*" Then
            GoTo СледующСтрока
        End If
       
        '3) Поиск на листе-источнике, в столбце A кода из листа-результата.
        On Error Resume Next
        r = 0
        r = WorksheetFunction.Match(коды_res(i, 1), rng_src, 0)
        On Error GoTo 0
       
        '4) Если найден код на листе-источнике.
        If r <> 0 Then
            ' Поиск последнего столбца на листе-источнике в найденной строке.
            lc = sh_src.Cells(r, sh_src.Columns.Count).End(xlToLeft).Column
            ' Вставка на лист-результат в столбец T проверки данных.
            sh_res.Cells(i, "T").Validation.Add Type:=xlValidateList, _
                Formula1:="=" & sh_src.Range(sh_src.Cells(r, "B"), sh_src.Cells(r, lc)).Address(False, False, , True)
        End If
       
СледующСтрока:
    Next i
   
    ' Включения.
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
   
    '6. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub