Excel VBA使用其他列表筛选列表

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

代码：

“列表”在另一个工作簿中，因此我需要宏先打开它。

---

当我尝试将范围更改为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, your" _
        & " selection will default to the current region for that 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 _
            , Criteria1:=arrCriteria, 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!", vbQuestion _
                + vbRetryCancel, "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

---

干杯非常感谢。@KeninS:很高兴我能帮忙！但是，当有人回答我们的问题时，我们在这里勾选“代码左侧”复选框，以使其成为可接受的答案。这样，其他搜索类似问题的人将知道解决方案是有效的。。。

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, your" _
        & " selection will default to the current region for that 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 _
            , Criteria1:=arrCriteria, 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!", vbQuestion _
                + vbRetryCancel, "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

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!" _
        , "Select Range", 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, Criteria1:=arrCriteria, Operator:=xlFilterValues
    Else
        With rngFirst.ListObject.Range
            .AutoFilter Field:=rngFirst.Column - .Column + 1 _
            , Criteria1:=arrCriteria, Operator:=xlFilterValues
        End With
    End If
    On Error GoTo 0
End Sub

Public Function GetRangeBySelection(ByVal prompt_ As String, 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_, Title:=title_, 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!", vbQuestion + vbRetryCancel, "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