Schleife durch filter-Kriterien

Ich weiß, das war fragte vor einer Weile, aber ich habe nicht gesehen, etwas, das ich als copy-paste bereit. hier ist, was ich kam mit. Es sollte funktionieren, für unbegrenzte Kriterien. Es entsteht eine neue Platte namens "temp", die gelöscht werden können, sobald Sie fertig sind.

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