Перебор критериев фильтрации

Question

я пытался понять это, но никакого прогресса ...

У меня есть фильтр (колонка D), и я пытаюсь создать цикл для каждого критерия (я получил в минимум 1000 критериев) на моем фильтре. Ex: Для каждого критерия на фильтре (столбец D), я буду запускать копию диапазона ...

Этот код разве работающих на всех:

Sub WhatFilters() 
    Dim iFilt As Integer 
    iFilt = 4 
    Dim iFiltCrit As Integer 
    Dim numFilters As Integer 
    Dim crit1 As Variant 


    ActiveSheet.Range("$A$1:$AA$4635").AutoFilter Field:=16, Criteria1:= _ 
      "Waiting" 

    numFilters = ActiveSheet.AutoFilter.Filters.Count 
    Debug.Print "Sheet(" & ActiveSheet.Name & ") has " & numFilters & " filters." 
    If ActiveSheet.AutoFilter.Filters.Item(iFilt).On Then 
     crit1 = ActiveSheet.AutoFilter.Filters.Item(iFilt).Criteria1 
     For iFiltCrit = 1 To UBound(crit1) 
      Debug.Print "crit1(" & iFiltCrit & ") is '" & crit1(iFiltCrit) 

      'Copy everything 

     Next iFiltCrit 
    End If 
End Sub 

Моя ошибка, кажется, идентифицирующий мою колонку фильтра ...

Answer 1

Это работало для меня

Sub WhatFilters() 
    Dim iFilt As Integer 
    Dim i, j As Integer 
    Dim numFilters As Integer 
    Dim crit1 As Variant 

    If Not ActiveSheet.AutoFilterMode Then 
     Debug.Print "Please enable AutoFilter for the active worksheet" 
     Exit Sub 
    End If 

    numFilters = ActiveSheet.AutoFilter.Filters.Count 
    Debug.Print "Sheet(" & ActiveSheet.Name & ") has " & numFilters & " filters." 

    For i = 1 To numFilters 
     If ActiveSheet.AutoFilter.Filters.Item(i).On Then 
      crit1 = ActiveSheet.AutoFilter.Filters.Item(i).Criteria1 
      If IsArray(crit1) Then 
       '--- multiple criteria are selected in this column 
       For j = 1 To UBound(crit1) 
        Debug.Print "crit1(" & i & ") is '" & crit1(j) & "'" 
       Next j 
      Else 
       '--- only a single criteria is selected in this column 
       Debug.Print "crit1(" & i & ") is '" & crit1 & "'" 
      End If 
     End If 
    Next i 
End Sub 

Answer 2

Я понимаю, что это было предложено некоторое время назад, но я гавань видел ничего, что я считаю копипаст готов. вот что я придумал. Он должен работать без ограничений. Он создает один новый лист под названием «temp», который можно удалить после завершения.

Dim currentCell As Long 
Dim numOfValues As Long 

Sub filterNextResult() 

' copy and move the data from the data sheet, column A (can be changed if needed) to a new sheet called "temp" 


' check to make sure there is at least 1 data point in column A on the temp sheet 
If currentCell = 0 Then 
Application.ScreenUpdating = False 
Call createNewTemp 
Application.ScreenUpdating = True 
End If 

' find the total number of unique data points we will be filtering by in column A of the temp sheet 
If numOfAccounts = 0 Then 
Application.ScreenUpdating = False 
Call findNumOfValues 
Application.ScreenUpdating = True 
End If 


With Sheet1.UsedRange 

.AutoFilter 1, Worksheets("temp").Range("A" & currentCell).Value 
currentCell = currentCell + 1 
' check to make sure we havent reached the end of clumn A. if so exit the sub 
If numOfValues + 1 = currentCell Then 
    MsgBox ("This was the last value to filter by") 
    Exit Sub 
End If 
End With 



End Sub 

'sub that will look for the number of values on the temp sheet column a 
Private Sub findNumOfValues() 
' count the number of non empty cells and assign that value (less 1 for the title in our case) to the numOfValues 
numOfValues = Worksheets("temp").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count 

End Sub 

Private Sub createNewTemp() 

Sheet1.Range("A:A").Copy 
ActiveWorkbook.Sheets.Add.Name = "temp" 

' remove duplicates 
Worksheets("temp").Range("A1").Select 
With ActiveWorkbook.ActiveSheet 
    .Paste 
    .Range("A:A").RemoveDuplicates Columns:=Array(1), Header:=xlYes 
End With 

' check to make sure there are vlaues in the temp sheet 
If Worksheets("temp").Range("A2").Value = "" Then 
    MsgBox "There are no filter values" 
    End 
Else 
    currentCell = 2 
End If 

Sheet1.Activate 
Sheet1.Range("A1").Select 
Selection.AutoFilter 

End Sub