Excel VBA Макросы: Как найти значение и создать рядом выпадающий список?

[Novik212]

Не могу написать макрос для создания выпадающего списка.
Нужно найти строку содержащую IAS-Код: "125*AXEL*at prior year*" и для неё в колонке "Т" создать выпадающий список. И так для всех строк.
IAS-Коды и значения к ним для выпадающего списка содержатся на другом листе.

Если в столбце T есть список, то макрос не анализирует эту строку.

[вложение удалено администратором]

[Администратор]

Списки в экселе есть нескольких видов. У вас в T30 список это элемент формы.
Ещё есть список, когда список это Проверка данных.

Вы хотите именно в том виде, как в T30? На первый взгляд это сложно сделать.

[Novik212]

Список как Проверка данных тоже подходит. С ним наверное будет и лучше.

[Администратор]

Если в столбце M нет данных вида 125*, то что должно быть в столбце T?

[Novik212]

Если в столбце M нет данных вида 125*, то должна остаться формула ВПР в столбце T.
Т.к. для других данных только один возможный вариант, поэтому справляется формула ВПР.
Для данных 125* вариантов три, поэтому и список.

[Администратор]

Вверху модуля вставьте эти строки:
Option Explicit
Option Compare Text
Option Base 1

Макрос

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

[свернуть]

[Novik212]

спасибо