AutoFilter a range using an Array
Requirement: Filter a range in order to show all the rows that contain all the items in an array.
i.e. for the Array = (“String1”, “String2”, “String3”, “String4”, “String5” )
The AutoFilter should include all the rows that contain “String1”, “String2”, “String3”, “String4” and “String5” in any position.
This should the equivalent to being able to perform something like this as a custom AutoFlter:
.AutoFilter Field:=1, _
Criteria1:=sCriteria1, Operator:=xlAnd, _
Criteria2:=sCriteria2, Operator:=xlAnd, _
Criteria3:=sCriteria3, Operator:=xlAnd, _
Criteria4:=sCriteria4, Operator:=xlAnd, _
Criteria5:=sCriteria5, Operator:=xlAnd, _
…, _
CriteriaN:=sCriteriaN
Solution: This proposed solution:
1. Process the array values (each two) in order to generate an array of filtered ranges
2. Obtains the intersection of filtered ranges array
3. Hides all the rows in the target range and unhides all the rows in the intersection range
4. Creates an array with all the values in step 4
5. Filters the target range applying the array generated in step 4
The advantages of this procedure are:
It does not loop through each of the rows of the target range.
Returns an AutoFilter, so additional filters can be applied to other fields without losing the Array AutoFilter.
Procedure:
Function Range_ƒFilter_ByArray_Contains(aCriteria As Variant, rTrg As Range, sMsg As String) As Boolean
Returns as boolean
Filters a Target range (rTrg) applying all the values in the Criteria array (aCriteria), returning also a message (sMsg) in case of Error.
Function Range_ƒFilter_ByArray_Contains(aCriteria As Variant, _
rTrg As Range, sMsg As String) As Boolean
Dim blAfByAry As Boolean
Dim arAFs() As Range
Dim ws As Worksheet
Dim bDim As Byte
Dim sCriteria1 As String, sCriteria2 As String
Dim rAFs As Range, aAFcontains As Variant
Dim b As Byte
Rem Validate Input
If (rTrg Is Nothing) Then sMsg = "Target range is invalid": GoTo Exit_Err
If Not (IsArray(aCriteria)) Then sMsg = "aCriteria is not an array": GoTo Exit_Err
On Error Resume Next
aCriteria = WorksheetFunction.Index(aCriteria, 0, 0)
If Err.Number <> 0 Then GoTo Exit_Err
bDim = UBound(aCriteria, 2)
If Err.Number = 0 Then sMsg = "aCriteria is not a single dimension array": GoTo Exit_Err
On Error GoTo Exit_Err
With Application
.EnableEvents = False
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With rTrg
Rem Clear AutoFilter
With .Worksheet
On Error Resume Next
If Not .AutoFilter Is Nothing Then .AutoFilter.Range.AutoFilter
On Error GoTo 0
End With
Rem Dimensioning AutoFilters Range Array
bDim = UBound(aCriteria)
blAfByAry = bDim > 2
If blAfByAry Then
If WorksheetFunction.IsOdd(bDim) Then bDim = 1 + bDim
bDim = (bDim / 2)
ReDim Preserve arAFs(1 To bDim)
End If
For b = 1 To UBound(aCriteria) Step 2
Rem Apply AutoFilter Criterias (2 each time)
sCriteria1 = aCriteria(b)
Select Case b
Case UBound(aCriteria)
.AutoFilter Field:=1, Criteria1:=sCriteria1
Case Else
sCriteria2 = aCriteria(1 + b)
.AutoFilter Field:=1, Criteria1:=sCriteria1, _
Operator:=xlAnd, Criteria2:=sCriteria2
End Select
Rem Set AutoFilter Range Item
If blAfByAry Then Set arAFs((1 + b) / 2) = rTrg.SpecialCells(xlCellTypeVisible)
Next: End With
If blAfByAry Then
Rem Set AutoFilters Range
Set rAFs = arAFs(1)
For b = 2 To UBound(arAFs)
Set rAFs = Application.Intersect(rAFs, arAFs(b))
Next
With rTrg
Rem Clear AutoFilter
rTrg.AutoFilter
Rem Apply AutoFilters Range
.EntireRow.Hidden = True
rAFs.EntireRow.Hidden = False
With ThisWorkbook
Rem Set AutoFilter Array Criteria
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
With ws
rAFs.Copy
.Cells(1).PasteSpecial
aAFcontains = .Cells(1).CurrentRegion.Value2
aAFcontains = WorksheetFunction.Transpose(aAFcontains)
ws.Delete
End With: End With
Rem Apply AutoFilter Array Criteria
rTrg.AutoFilter Field:=1, _
Criteria1:=aAFcontains, Operator:=xlFilterValues
End With: End If
Range_ƒFilter_ByArray_Contains = True
Exit_Err:
With Err
If .Number <> 0 Then sMsg = "Error: " & .Number & vbLf & vbTab & .Description
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
End Function
The procedure should be used like this:
Set rTrg = ThisWorkbook.Worksheets(kWsh).Range(kRng)
If Not (Range_ƒFilter_ByArray_Contains(aCriteria, rTrg, sMsg)) Then
MsgBox sMsg, vbCritical, "Range_ƒFilter_ByArray_Contains"
End If
Note: This solution only handles the xlAnd operator in line with the original OP's question, nevertheless it can be easily modified to include work also with the xlOr operator.
