Фильтр содержит критерии с массивом

Question

У меня есть код для критериев фильтрации на основе массива, но он фильтрует точное совпадение и не содержит.

Я хочу отфильтровать все, что содержит

У меня есть код, который фильтрует точное соответствие

Criteria = Worksheets("Sheet1").Range("A1:A140") & Criteri & :*" - не работает

    Sub Filter969696()

Dim Criteria As Variant
Dim cri() As String

Criteria = Worksheets("Sheet1").Range("A1:A140")

ReDim Preserve cri(UBound(Criteria))

For I = LBound(Criteria) To UBound(Criteria)

    cri(I) = Criteria(I, 1)

Next

Worksheets("AP").Range("$A$1:$h$100").AutoFilter Field:=3, Criteria1:=cri, Operator:=xlFilterValues

End Sub

Фильтр всех значений содержит предоставленный массив

Answer 1

Здесь, попробуйте этот код:

Я сделал его довольно большим и сложным, но он должен работать.

Слишком большое ограничение Excel для 2 Содержит , я добавил точные числа по одному в новый массив и использовал его, чтобы сразу применить фильтр.

Sub Filter969696()

Dim Criteria As Variant
Dim cri() As String
Dim cri2() As String
Dim i As Integer
Dim j As Integer
Dim k As Integer

Criteria = Worksheets("Sheet1").Range("A1:A140")

ReDim Preserve cri(UBound(Criteria))
ReDim Preserve cri2(1)

For i = LBound(Criteria) To UBound(Criteria)

    cri(i) = "=*" & Criteria(i, 1) & "*"
    Worksheets("AP").Range("$A$1:$h$100").AutoFilter Field:=3, Criteria1:=cri(i), Operator:=xlFilterValues

    j = UBound(cri2)

    ReDim Preserve cri2(j + Worksheets("AP").Range("$A$1:$h$100").Columns(1).SpecialCells(xlCellTypeVisible).Count)

        For Each rw In Worksheets("AP").Range("$A$1:$h$100").SpecialCells(xlCellTypeVisible).Rows

                cri2(j + 1) = Cells(rw.Row, 1).Value
                j = j + 1

        Next

Next

Worksheets("AP").Range("$A$1:$h$100").AutoFilter Field:=3, Criteria1:=cri2, Operator:=xlFilterValues


End Sub