使用数组自动过滤范围
要求：过滤范围以显示包含数组中所有项目的所有行。
即对于 Array = (“String1”、“String2”、“String3”、“String4”、“String5”)
自动筛选应包括在任何位置包含“String1”、“String2”、“String3”、“String4”和“String5”的所有行。
这应该相当于能够作为自定义 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
解决方案：这个建议的解决方案：
1. 处理数组值（每两个）以生成过滤范围数组
2.获取过滤范围数组的交集
3.隐藏目标范围内的所有行，取消隐藏交集范围内的所有行
4. 使用步骤 4 中的所有值创建一个数组
5. 应用步骤 4 中生成的数组过滤目标范围
此程序的优点是：
它不会循环遍历目标范围的每一行。
返回一个自动过滤器，因此可以将其他过滤器应用于其他字段而不会丢失数组自动过滤器。
程序：
函数Range_ƒFilter_ByArray_Contains（aCriteria As Variant, rTrg As Range, sMsg As String）As Boolean
返回为布尔值
应用标准数组 (aCriteria) 中的所有值过滤目标范围 (rTrg)，如果出现错误，还会返回一条消息 (sMsg)。
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
程序应该这样使用：
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
注意： 此解决方案仅处理与原始 OP 问题一致的 xlAnd 运算符，但可以轻松修改它以包含 @987654325 的工作@运算符。