Автофильтр на основе переменных критериев

Question

Поскольку я новичок в кодировании VBA, я пытаюсь написать код, который фильтрует данные на основе переменных ячеек, поступающих из другого фильтра на том же листе, но оставляю ответы с первым значением только выбранных критериев, любые предложения ?

Sub FilterCriteria()
Dim vCrit As Variant
Dim wsO As Worksheet
Dim wsL As Worksheet

Dim rngOrders As Range
Set wsO = Worksheets("Orders")
Set wsL = Worksheets("Lists")
Set rngOrders = wsO.Range("$A$1").CurrentRegion

rngOrders.AutoFilter _
Field:=6, Criteria1:=Array("51", "55", "71"), _
Operator:=xlFilterValues


Dim rngCrit As Range
Set rngCrit = wsO.Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)

rngOrders.AutoFilter Field:=6 'To remove other filter to be able to look up in the whole sheet

vCrit = rngCrit.Value

rngOrders.AutoFilter _
    Field:=4, _
    Criteria1:=Application.Transpose(vCrit), _
    Operator:=xlFilterValues

End Sub

Answer 1

Вы должны установить отфильтрованный диапазон для видимых ячеек только с использованием .SpecialCells (xlCellTypeVisible), но это может дать вам несмежный диапазон, такой как $ D $ 1: $ D $ 2, $ D $ 6, $ D $ 9 с несколькими областями, которые нужно обрабатывать по-разному в непрерывном диапазоне, как $ DS1: $ D $ 9. Одним из способов было бы провести l oop через ячейки в этом диапазоне и построить массив для 2-го фильтра. Например

Option Explicit

Sub FilterCriteria()
    Dim vCrit As Variant
    Dim wsO As Worksheet
    Dim wsL As Worksheet

    Dim rngOrders As Range
    Set wsO = Worksheets("Orders")
    Set wsL = Worksheets("Lists")
    Set rngOrders = wsO.Range("$A$1").CurrentRegion

    Dim rng As Range
    rngOrders.AutoFilter _
        Field:=6, Criteria1:=Array("51", "55", "71"), _
        Operator:=xlFilterValues
    Set rng = rngOrders.Columns(4).SpecialCells(xlCellTypeVisible)
    'Debug.Print rng.Address

    Dim arr() As String, cell As Range, i As Integer
    If rng.Cells.Count > 2 Then
        ReDim arr(rng.Cells.Count - 2)
    Else 
        ReDim arr(0)
    End If

    i = 0

    ' build array
    For Each cell In rng
       If i > 0 Then ' skip header
           arr(i - 1) = cell.Value
       End If
       i = i + 1
    Next
    'Debug.Print Join(arr, ",")

    rngOrders.AutoFilter Field:=6 'To remove other filter to be able to look up in the whole sheet
    rngOrders.AutoFilter _
        Field:=4, _
        Criteria1:=arr, _
        Operator:=xlFilterValues

End Sub