Question

我知道我可以在使用AutoFilter的情况下使用VBA在Excel中过滤范围，例如：

Sub name()
ActiveSheet.Range("$A$12:$Y$74").AutoFilter Field:=22, Criteria1:="String"
End Sub)

...那工作很好。但是，我正在努力使其更加复杂。有谁知道如何在VBA中实现以下示例？

我想做的是从每个选中标记的列表项之间的List Box过滤Operator:=xlAnd中带有选中标记的项。

示例：如果在以下String1中选中String2和List Box，则AutoFilter函数应返回包含String1和{{1}的所有行}。对于下表，该行将是第2行和第4行。

String2

Answer 1

还没有测试过，但是从理论上讲，它也可以与自动过滤器一起工作：

Sub name()
ActiveSheet.Range("$A$12:$Y$74").AutoFilter Field:=22, Criteria1:="*String1*", _
Operator:=xlOr, Criteria2:="*String2*"
End Sub)

如果您可以将String1和String2修改为在代码或列表框中包含*，我认为这应该可以找到那些方案。

Answer 2

如果您要过滤多个值，我要做的就是将它们的值添加到数组中，然后使用数组中的值来过滤范围，例如：

Sub Autofiler_Array()
Dim ws As Worksheet: Set ws = ThisWorkbook.ActiveSheet
'declare and set the worksheet you are working with
Dim myarray As Variant
myarray = Array("String1", "String2", "String3")
'declare and assign values to Array

If ws.FilterMode Then ws.Range("$A$12:$Y$74").AutoFilter
'if Worksheet already is Filtered, then remove Autofilter
ws.Range("$A$12:$Y$74").AutoFilter Field:=22, Criteria1:=myarray, Operator:=xlFilterValues
'Autofilter with Array Values on Column 22 of the applicable range
End Sub

更新：

阅读您的评论和更新的问题后，我相信以下内容将达到您想要的结果，而不是使用自动筛选，下面的代码将遍历您的行，检查单元格是否包含数组中的所有值，如果未隐藏他们行：

Sub Auto_Filter()
Dim ws As Worksheet: Set ws = ThisWorkbook.ActiveSheet
'declare and set the worksheet you are working with
Dim arrWords  As Variant
arrWords = Array("String1", "String2")
'declare and assign values to Array
ws.Cells.EntireRow.Hidden = False
'unhide all rows
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get last row with data in Column A

For i = 2 To LastRow
'loop through rows
    For Each aWord In arrWords 'loop through Array values
        If Not InStr(ws.Cells(i, 22).Value, aWord) > 0 Then
            ws.Rows(i).EntireRow.Hidden = True
            'if values from Array not found in cell, then hide row
        End If
    Next
Next i
End Sub

Answer 3

使用数组自动过滤范围

要求：：过滤范围以显示包含数组中所有项目的所有行。
即对于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（作为变量的标准，作为范围的rTrg，作为字符串的sMsg）作为布尔值
返回为布尔值应用Criteria数组（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运算符，但是可以轻松对其进行修改以包含工作也可以使用xlOr运算符。

Answer 4

这是我的解决方案，灵感来自Xabier的答案。它具有两个“方案”。

1）显示行，其中要检查的单元格中的字符串包含String1 或 String2

2）显示行，其中要检查的单元格中的字符串包含String1 和 String2

Sub AoP()

StartRow = 13
EndRow = 73
TargetColumn = 19 '(R)

LengthListBox = (ActiveSheet.ListBox1.ListCount - 1) ' Number of ListBox entries

ReDim TestXYZ(LengthListBox) As Integer 'Permanent list of checkmarked ListBox entries as ones and zeros
ReDim CheckList(LengthListBox) As String 'Permanent list of checkmarked ListBox entries as strings
ReDim Matches(LengthListBox) As Integer 'Temporary list of matches between search criteria and cell content

'''''''''''''''''''''''''''''''''''''''''''''''''
' Create arrays with information on the ListBox
'''''''''''''''''''''''''''''''''''''''''''''''''

For i = 0 To LengthListBox 'For 0 to length of ListBox
    If ActiveSheet.ListBox1.Selected(i) Then 'Loop
        TestXYZ(i) = 1 ' Checkmarked = 1
        CheckList(i) = ActiveSheet.ListBox1.List(i)
    Else
        TestXYZ(i) = 0 ' Not checkmarked = 0
    End If
Next i

'''''''''''''''''''''''''''''''''''''''''''''''''
' Hide rows that do not match a specific criteria
'''''''''''''''''''''''''''''''''''''''''''''''''

'If OR is selected as an operator
If ActiveSheet.CheckBox_AoP_Or.Value = True Then ' If "Or" is selected as an operator
    For i = StartRow To EndRow 'For each row
        ActiveSheet.Rows(i).EntireRow.Hidden = True 'Hide all rows ifnot
        For j = 0 To LengthListBox 'For 0 to length of ListBox
            If Len(CheckList(j)) > 0 Then
                If InStr(1, ActiveSheet.Cells(i, TargetColumn).Value, CheckList(j), vbTextCompare) > 0 Then 'If the cell contains the checked ListBox string
                    ActiveSheet.Rows(i).EntireRow.Hidden = False 'Unhide the row
                End If
            End If
        Next j
    Next i
'If OR is NOT selected as an operate (behave like AND)
Else ' If "Or" is NOT selected as an operator
    For i = StartRow To EndRow 'For each row
        ActiveSheet.Rows(i).EntireRow.Hidden = True 'Hide all rows ifnot
        For k = 0 To LengthListBox 'Makes sure that the matches are set to zero
            Matches(k) = 0
        Next k
        For j = 0 To LengthListBox 'Parse through all list box entries
            If TestXYZ(j) = 1 Then ' If they have been checkmarked
                If InStr(1, ActiveSheet.Cells(i, TargetColumn).Value, CheckList(j), vbTextCompare) > 0 Then ' ... and if they are contained in the string
                    Matches(j) = 1 ' Contained = 1
                Else
                    Matches(j) = 0 ' Not contained = 0
                End If
            End If
        Next j
        If Excel.WorksheetFunction.Sum(TestXYZ) = Excel.WorksheetFunction.Sum(Matches) Then 'If all are contained (all are matched so the sum of 1 is equal)
            ActiveSheet.Rows(i).EntireRow.Hidden = False '... then unhide
        End If
    Next i
End If

End Sub

VBA AutoFilter用于选中的列表框项目

4 个答案: