Excel VBA Макросы. Фильтр по нескольким значениям по частичному совпадению.

[Телефон]

Возможно ли отфильтровать значения в столбце на одном листе, по частичному совпадению в значениях другого листа?

Пробовала редактировать код записанного макроса, но результата это не принесло:
Sub Макрос_test()
    ActiveSheet.Range("$A$1:$D$17394").AutoFilter Field:=4, Criteria1:= _
        Array("=**Лист1!A1:A5**"), Operator:=xlAnd
End Sub

При явном указании только двух условий макрос работает и фильтрует все строки, которые содержат слова "здание" или "А/М":
Sub Макрос555()
    ActiveSheet.Range("$A$1:$D$17394").AutoFilter Field:=4, Criteria1:= _
        "=**здание**", Operator:=xlOr, Criteria2:="=**А/М**"
End Sub

Прошу помочь с созданием макроса, который отфильтрует список по списку (массиву значений) на другом листе.

[Посетитель]

Такой возможности нет в экселе: нельзя в автофильтре фильтровать по частичному совпадению по трём и более фразам - максимум две. В том числе, нельзя делать фильтр по частичному совпадению по трём и более фразам с помощью массива.
По трём и более фразам можно фильтровать по полному совпадению.

Предлагаю обходной вариант. Макрос собирает в массив данные по частичному совпадению без использования автофильтра, а затем подставляет массив в автофильтр и автофильтр фильтрует по полному совпадению.

Макрос

Option Explicit

Sub jjj()
    ' - -
    ' - порядковый номер фильтруемого столбца целевого диапазона
    Const l_FILTERED_FIELD As Long = 1
    ' - -
    Dim rngData As Range, arrData(), i&, j&, n&
    ' - -
    ' - массив ключевых слов для фильтрации
    Dim arrWords(): arrWords = VBA.Array("Апельсин", "Груша", "Яблоко"): n = UBound(arrWords, 1)
    ' - -
    ' - массив для целевых значений (отобранным по ключевым словам)
    Dim dictFilterKeys As Object: Set dictFilterKeys = CreateObject("Scripting.Dictionary")
    ' - -
    With ActiveSheet
        ' - -
        ' - если на активном листе вкл. автофильтр, то выкл. его
        If .AutoFilterMode Then .AutoFilterMode = False
        ' - -
        ' - целевой диапазон для фильтрации
        Set rngData = .Cells(1).CurrentRegion
        ' - -
    End With 'ActiveSheet
    ' - -
    ' - содержимое целевого столбца из диапазона в массив
    arrData = rngData.Columns(l_FILTERED_FIELD).Value
    ' - -
    ' - цикл по массиву со 2й строки, т.к. 1я - заголовок
    For i = 2 To UBound(arrData, 1)
        ' - -
        ' - если текущего элем. массива нет в словаре, то
        If Not dictFilterKeys.Exists(arrData(i, 1)) Then
            ' - -
            ' - цикл по клчевым словам
            For j = 0 To n
                ' - -
                ' - если в текущем элем. массива имеется текущее ключевое слово, то _
                    вносим текущем элем. массива в словарь (значение не важно, потому = 1) _
                    и выходим из данного цикла
                If InStr(1, arrData(i, 1), arrWords(j), vbTextCompare) > 0 Then dictFilterKeys(arrData(i, 1)) = 1: Exit For
                ' - -
            Next j
            ' - -
        End If 'Not dictFilterKeys.Exists(arrData(i, 1))
        ' - -
    Next i
    ' - -
    ' - если словарь не пуст, то фильтруем по отобранным ключевым значениям
    If dictFilterKeys.Count Then _
        rngData.AutoFilter Field:=l_FILTERED_FIELD, Criteria1:=dictFilterKeys.Keys, Operator:=xlFilterValues Else _
        MsgBox "Нечего фильтровать!", vbExclamation
    ' - -
End Sub

[свернуть]