Автофильтровать диапазон с использованием массива
Требование: Фильтровать диапазон, чтобы показать все строки, содержащие все элементы в массиве.
т.е. для массива = («String1», «String2», «String3», «String4», «String5»)
Автофильтр должен включать все строки, содержащие «String1», «String2», «String3», «String4» и «String5» в любой позиции.
Это должно быть эквивалентно возможности выполнять что-то подобное в качестве пользовательского автофильтра:
.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
AdvПреимущества этой процедуры:
Он не проходит по каждой строке целевого диапазона.
Возвращает автофильтр, поэтому дополнительные фильтры можно применять к другим полям без потери автофильтра массива.
Процедура:
Функция Range_ƒFilter_ByArray_Contains (aCriteria As Variant, rTrg As Range, sMsg As String) Как Boolean
Возвращает как логическое значение Фильтрует целевой диапазон (rTrg), применяя все значения в массиве Criteria (aCriteria), возвращая также сообщение (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
Примечание: Это решение обрабатывает только оператор xlAnd в соответствии свопрос оригинального ОП, тем не менее, его можно легко изменить, включив работу также с оператором xlOr.