VBA filtering list using another list

Question

I'm trying to filter the ID in a table, using IDs from another list. However, when I try to do so the macro only filters the first value in the list.

Table Format

Code:

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

The "List" is in another workbook so I need the macro to open it first. When I try changing the Range to A4:A103 the filter will just use the A4 (first value in the range).

Answer 1

You can do all this by selecting the ranges (directly in the Excel interface). The following code is reusable:

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

Just run the FilterBySelection method

EDIT 1

Or, if you would like to have less restrictions and be able to select multiple ranges for the filtering values then use this instead:

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

Answer 2

Try the next way, please:

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

The column list must be transposed on a row. Otherwise, only its first element will be used.