Блог

Я пытаюсь отфильтровать идентификатор в таблице, используя идентификаторы из другого списка. Однако, когда я пытаюсь это сделать, макрос фильтрует только первое значение в списке.

Формат таблицы

Код:

 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!" _
        amp; vbNewLine amp; "Please select a single continuous range!" _
        amp; vbNewLine amp; vbNewLine amp; "Note that by selecting a single cell, your" _
        amp; " 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!" _
        amp; vbNewLine amp; "Please select a single continuous range!" _
        amp; vbNewLine amp; vbNewLine amp; "Note that by selecting a single cell, your" _
        amp; " 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 " amp; rng.Areas.Count _
                amp; " different ranges!" amp; vbNewLine amp; "Please select only 1 " _
                amp; "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" amp; vbNewLine _
                amp; "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
  

Просто запустите 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!" _
        amp; vbNewLine amp; "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 " amp; rng.Areas.Count _
                amp; " different ranges!" amp; vbNewLine amp; "Please select only 1 " _
                amp; "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