VBA筛选列表使用另一个列表

问题描述

我正在尝试使用另一个列表中的ID来过滤表中的ID。但是，当我尝试这样做时，宏只会过滤列表中的第一个值。

Sub test()

Dim wb As Workbook

Set wb = ThisWorkbook

ActiveSheet.AutoFilterMode = False

Workbooks.Open "C:\List.xlsx"

Criteria = Worksheets("DataArray").Range("A3:A103")

wb.Activate

ActiveSheet.Range("$A$8:$BE$5000").AutoFilter Field:=3,Criteria1:=Criteria,Operator:=xlFilterValues

End Sub

“列表”在另一个工作簿中，因此我需要首先打开它的宏。当我尝试将范围更改为A4：A103时，过滤器将仅使用A4（该范围内的第一个值）。

解决方法

请尝试以下方法：

Dim Crit As Variant
Set Crit = Worksheets("DataArray").Range("A3:A103").Value
ActiveSheet.Range("$A$8:$BE$5000").AutoFilter Field:=3,Criteria1:=Application.Transpose(Crit),Operator:=xlFilterValues

列列表必须在一行上转置。否则，将仅使用其第一个元素。

您可以通过选择范围（直接在Excel界面中）来完成所有这些操作。以下代码是可重用的：

Option Explicit

Public Sub FilterBySelection()
    Dim rngFirst As Range
    Dim rngSecond As Range
    '
    'Get Ranges from User Selection
    Set rngFirst = GetRangeBySelection("Select range to filter!" _
        & vbNewLine & "Please select a single continuous range!" _
        & vbNewLine & vbNewLine & "Note that by selecting a single cell,your" _
        & " selection will default to the current region for that cell!" _,"Select Range")
    If rngFirst Is Nothing Then Exit Sub
    '
    Set rngSecond = GetRangeBySelection("Select range containing filtering values!" _
        & vbNewLine & "Please select a single continuous range!" _
        & vbNewLine & vbNewLine & "Note that by selecting a single cell,"Select Range")
    If rngSecond Is Nothing Then Exit Sub
    '
    'Filter first range using values from the second range
    Dim arrValues() As Variant: arrValues = rngSecond.Value2
    Dim arrCriteria() As Variant
    Dim i As Long
    Dim v As Variant
    '
    'Criteria values must be a 1-dimension array
    ReDim arrCriteria(0 To rngSecond.Count - 1)
    i = 0
    For Each v In arrValues
       arrCriteria(i) = CStr(v) 'Criteria must be string data type
       i = i + 1
    Next v
    '
    'Filter
    On Error Resume Next
    If rngFirst.ListObject Is Nothing Then
        rngFirst.AutoFilter
        rngFirst.AutoFilter Field:=1,Criteria1:=arrCriteria,Operator:=xlFilterValues
    Else
        With rngFirst.ListObject.Range
            .AutoFilter Field:=rngFirst.Column - .Column + 1 _,Operator:=xlFilterValues
        End With
    End If
    On Error GoTo 0
End Sub

Public Function GetRangeBySelection(ByVal prompt_ As String,ByVal title_ As String) As Range
    Dim rng As Range
    '
    Do While rng Is Nothing
        On Error Resume Next
        Set rng = Application.InputBox(Prompt:=prompt_,Title:=title_,Type:=8)
        If rng.Cells.Count = 1 Then Set rng = rng.CurrentRegion
        On Error GoTo 0
        If rng Is Nothing Then Exit Function
        '
        On Error GoTo ErrorHandler
        If rng.Areas.Count > 1 Then
            If MsgBox("Your selection contains " & rng.Areas.Count _
                & " different ranges!" & vbNewLine & "Please select only 1 " _
                & "range!",vbQuestion + vbRetryCancel,"Cancelled") _
            <> vbRetry Then Exit Function
            Set rng = Nothing
        ElseIf rng.Cells.Count = 1 Then
            If MsgBox("No region found from selected cell" & vbNewLine _
                & "Please select more than 1 cell!",vbQuestion _
                + vbRetryCancel,"Cancelled") <> vbRetry Then Exit Function
            Set rng = Nothing
        ElseIf rng.Rows.Count = 1 Then
            If MsgBox("Please select more than 1 row!","Cancelled") <> vbRetry Then Exit Function
            Set rng = Nothing
        End If
    Loop
    Set GetRangeBySelection = rng
Exit Function
ErrorHandler:
    MsgBox "Try selecting a smaller range next time",vbInformation,"Cancelled"
End Function

只需运行FilterBySelection方法

编辑1

或者，如果您希望减少限制并能够为过滤值选择多个范围，请改用以下方法：

Option Explicit

Public Sub FilterBySelection()
    Dim rngFirst As Range
    Dim rngSecond As Range
    '
    'Get Ranges from User Selection
    Set rngFirst = GetRangeBySelection("Select range to filter!" _
        & vbNewLine & "Please select a single continuous range!" _,"Select Range",False)
    If rngFirst Is Nothing Then Exit Sub
    '
    Set rngSecond = GetRangeBySelection("Select range(s) containing filtering values!" _,True)
    If rngSecond Is Nothing Then Exit Sub
    '
    'Filter first range using values from the second range
    Dim rng As Range
    Dim arrValues() As Variant
    Dim arrCriteria() As Variant
    Dim i As Long
    Dim v As Variant
    '
    'Criteria values must be a 1-dimension array
    i = 0
    ReDim arrCriteria(0 To rngSecond.Count - 1)
    For Each rng In rngSecond.Areas
        If rng.Count = 1 Then
            ReDim arrValues(0 To 0)
            arrValues(0) = rng.Value2
        Else
            arrValues = rng.Value2
        End If
        For Each v In arrValues
           arrCriteria(i) = CStr(v) 'Criteria must be string data type
           i = i + 1
        Next v
    Next
    '
    'Filter
    On Error Resume Next
    If rngFirst.ListObject Is Nothing Then
        rngFirst.AutoFilter
        rngFirst.AutoFilter Field:=1,ByVal title_ As String _,allowMultiArea As Boolean) As Range
    Dim rng As Range
    '
    Do While rng Is Nothing
        On Error Resume Next
        Set rng = Application.InputBox(Prompt:=prompt_,Type:=8)
        On Error GoTo 0
        If rng Is Nothing Then Exit Function
        '
        On Error GoTo ErrorHandler
        If rng.Areas.Count > 1 And Not allowMultiArea Then
            If MsgBox("Your selection contains " & rng.Areas.Count _
                & " different ranges!" & vbNewLine & "Please select only 1 " _
                & "range!","Cancelled") _
            <> vbRetry Then Exit Function
            Set rng = Nothing
        End If
    Loop
    Set GetRangeBySelection = rng
Exit Function
ErrorHandler:
    MsgBox "Try selecting a smaller range next time","Cancelled"
End Function

autofilter excel excel filter filter