VBA filtering list using another list - excel

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

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.

Answer 2

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