I am trying to filter column with multiple criteria using an array.
I think it can be done using a Dictionary like the accepted answer of this question Link.
I adapted the code a little , But I got (Type Mismatch error) at this line:
If Application.Match(filter_Criteria(i), subStrings, 0) Then
Note: If there is another answer (without using a helper column) is highly welcomed.
Sub AutoFilter_With_Multiple_Criteria()
Const filter_Column As Long = 2
Const filter_Delimiter As String = " "
Dim filter_Criteria() As Variant
filter_Criteria = Array("Cathodic Protection", "C.P", "Riser")
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg As Range
Set rg = ws.UsedRange.Resize(ws.UsedRange.Rows.count - 1).Offset(1) 'the source range (UsedRange except the first Row)
Dim rCount As Long, arr() As Variant
rCount = rg.Rows.count - 1
arr = rg.Columns(filter_Column).Resize(rCount).Offset(1).value 'Write the values from criteria column to an array.
Dim dict As New Dictionary 'Write the matching strings to the keys (a 1D array) of a dictionary.
Dim subStrings() As String, r As Long, i As Long, rStr As String
For r = 1 To rCount 'Loop through the elements of the array.
rStr = arr(r, 1) 'Convert the current value to a string and store it in a variable.
If Len(rStr) > 0 Then 'is not blank
subStrings = Split(rStr, filter_Delimiter) 'Split the string into an array.
For i = 0 To UBound(filter_Criteria)
If Application.Match(filter_Criteria(i), subStrings, 0) Then
If Not dict.Exists(rStr) Then
dict(rStr) = Empty
End If
End If
Next i
End If
Next r
If dict.count > 0 Then
rg.AutoFilter Field:=filter_Column, Criteria1:=dict.Keys, Operator:=xlFilterValues 'use the keys of the dictionary (a 1D array) as a Criteria
End If
End Sub
If you need to filter by cells containing any of the criteria array element, please try the next adapted code. It assumes that you need to filter on the first column (A:A):
Sub AutoFilter_With_Multiple_Criteria()
Const filter_Column As Long = 1 'column A:A
Dim filter_Criteria() As Variant: filter_Criteria = Array("*Cathodic Protection*", "*C.P*", "*Riser*") 'changed array to avoid exact matches!
Dim ws As Worksheet: Set ws = ActiveSheet
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim rg As Range
Set rg = ws.UsedRange.Resize(ws.UsedRange.rows.count - 1).Offset(1) 'the source range (UsedRange except the first Row)
Dim rCount As Long, arr() As Variant, El
rCount = rg.rows.count - 1
arr = rg.Columns(filter_Column).Resize(rCount).Offset(1).Value 'Write the values from criteria column to an array.
Dim dict As New scripting.Dictionary 'Write the matching strings to the keys (a 1D array) of a dictionary.
Dim r As Long
For r = 1 To rCount 'Loop through the elements of the array.
If Len(arr(r, 1)) > 0 Then 'is not blank
For Each El In filter_Criteria
If arr(r, 1) Like El Then dict(arr(r, 1)) = vbNullString: Exit For
Next El
End If
Next r
If dict.count > 0 Then
rg.AutoFilter field:=filter_Column, Criteria1:=dict.keys, Operator:=xlFilterValues 'use the keys of the dictionary (a 1D array) as a Criteria
End If
End Sub
Edited:
If you need the opposite (to filter what does not match any array element, you should change the dictionary loading iteration in the next way:
Dim boolFound as Boolean
For r = 1 To rCount
If Len(arr(r, 1)) > 0 Then
boolFound = False
For Each El In filter_Criteria
If arr(r, 1) Like El Then boolFound = True: Exit For
Next El
If Not boolFound Then dict(CStr(arr(r, 1))) = vbNullString 'CStr used in case of numeric values, which be converted to string in order to be taken in consideration...
End If
Next r
Debug.Print Join(dict.keys, "|"): Stop 'just to see the new built array...