VBA 按字符串数组作为条件过滤

Question

I have a column that I need to filter and check if a cell contains any words from a list.

If I had a list like this

Targeted = Array("Word 1", "Word 2", "Word 3")

I would like to filter and see any cell that contains any of those words, I thougth something like this would do it:

Dim Targeted As Variant
Targeted = Array("*Word 1*", "*Word 2*", "*Word 3*")

Dim Targeted_ColNum As Integer
Targeted_ColNum = Range("1:1").Find("Targeted", , xlValues, xlWhole).Column

Cells.AutoFilter Field:=Targeted_ColNum, Criteria1:=Targeted

But I only seem to be filtering by the last word, so in this example I am only seeing cells that contain the text “Word 3”, as oppose to seeing any cell with “Word 1“ or “Word 2” or “Word 3” in them

What am I doing wrong?

Answer 1

after learning a lot i figurred it out, this does not work with arrays BUT i does work with diccionaries keys, so what i needed to do was to build a dictionary with all the entreys that i want to filter out.

Dim dicCriteria As Object
Dim ColumToFilter As Variant
Dim i As Long
    
Set dicCriteria = CreateObject("Scripting.Dictionary")
dicCriteria.CompareMode = 1 'vbTextCompare

'this is just how i find the specific range to filter out
With Range(Cells(2, LookFor_ColNum), Cells(lastrow, LookFor_ColNum))
    ColumToFilter = .Cells.Value
    For i = 1 To UBound(ColumToFilter, 1)
        If Not dicCriteria.Exists(ColumToFilter(i, 1)) Then
            Dim k As Integer
            For k = LBound(words) To UBound(words)
                Select Case True
                    Case ColumToFilter(i, 1) Like words(k)
                        dicCriteria.Add Key:=ColumToFilter(i, 1), Item:=ColumToFilter(i, 1)
                End Select
            Next k
        End If
    Next i

here i am creating an empty dictionary called dicCriteria then i am getting the values of the column i want to filter into an array called ColumntoFilter

now i go though every value in the array and i check, first if its already on the dictionary, then if its not now i go whogh the array i called words

and i check if its like any of the values in that array, if it is then i add the current Columntofilter value into the dictionary, as both the key and the item

by the end i end up with a dictonary populated with all the entreys that matched the criteria.

now i just need to filter using the dictionary keys

If CBool(dicCriteria.Count) Then
        .AutoFilter Field:=LookFor_ColNum, Criteria1:=dicCriteria.keys, Operator:=xlFilterValues
End If

and thats it ahah a bit longer than expected but it works

Answer 2

AutoFilter With Multiple Wildcard Criteria in Column

• Copy the complete code into a standard module, eg Module1
• Adjust the values in the constants section.
• Only run the first procedure filterMultipleCriteria , the rest is being called by it.

The Code

Option Explicit

Sub filterMultipleCriteria()
    
    Const wsName As String = "Sheet1"
    Const HeaderRow As Long = 1
    Const HeaderCriteria As String = "Targeted"
    Const CriteriaStrings As String = "Word 1,Word 2,Word 3"
    Const CriteriaDelimiter As String = ","
    
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    Dim ws As Worksheet
    Set ws = wb.Worksheets(wsName)
    If ws Is Nothing Then Exit Sub
    Debug.Print ws.Name
    
    Dim cel As Range
    Set cel = findCellInRow(ws.Rows(HeaderRow), HeaderCriteria)
    If cel Is Nothing Then Exit Sub
    Debug.Print cel.Address
    
    Dim rng As Range
    Set rng = defineNonEmptyColumnRange(cel.Offset(1))
    If rng Is Nothing Then Exit Sub
    Debug.Print rng.Address
    
    Dim Data As Variant
    Data = getColumn(rng)
    If IsEmpty(Data) Then Exit Sub
    Debug.Print "[" & LBound(Data, 1) & "," & UBound(Data, 1) & "]"
    
    Dim wcFilter As Variant
    wcFilter = getWildcardFilters(Data, CriteriaStrings, CriteriaDelimiter)
    If IsEmpty(wcFilter) Then Exit Sub
    Debug.Print Join(wcFilter, vbLf)

    ws.Cells.AutoFilter Field:=cel.Column, Criteria1:=wcFilter, _
        Operator:=xlFilterValues

End Sub

Function findCellInRow(RowRange As Range, ByVal Criteria As Variant) As Range
    Dim cel As Range
    Set cel = RowRange.Find(What:=Criteria, _
        After:=RowRange.Cells(RowRange.Columns.Count), LookIn:=xlFormulas)
    If Not cel Is Nothing Then Set findCellInRow = cel
End Function

Function defineNonEmptyColumnRange(FirstCell As Range) As Range
    Dim cel As Range
    With FirstCell.Resize(FirstCell.Worksheet.Rows.Count - FirstCell.Row + 1)
        Set cel = .Find(What:="*", LookIn:=xlFormulas, _
            SearchDirection:=xlPrevious)
        If Not cel Is Nothing Then
            Set defineNonEmptyColumnRange = .Resize(cel.Row - .Row + 1)
        End If
    End With
End Function

Function getColumn(ColumnRange As Range) As Variant
    If ColumnRange.Columns(1).Rows.Count > 1 Then
        getColumn = ColumnRange.Value
    Else
        Dim Data As Variant: ReDim Data(1 To 1, 1 To 1)
        Data(1, 1) = ColumnRange.Value
        getColumn = Data
    End If
End Function

Function getWildcardFilters(ColumnData As Variant, CriteriaStrings As String, _
    Optional ByVal CriteriaDelimiter As String = ",") _
As Variant
    Dim Crit As Variant: Crit = Split(CriteriaStrings, CriteriaDelimiter)
    Dim cUpper As Long: cUpper = UBound(Crit)
    Dim Key As Variant, i As Long, n As Long
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For i = 1 To UBound(ColumnData, 1)
            Key = ColumnData(i, 1)
            For n = 0 To cUpper
                If InStr(1, Key, Crit(n), vbTextCompare) > 0 Then
                    .Item(Key) = Empty
                    Exit For
                End If
            Next n
        Next i
        If .Count > 0 Then getWildcardFilters = .Keys
    End With
End Function