循环过滤条件

Question

我一直在尝试解决这个问题，但没有任何进展......

我有一个过滤器（D 列），我正在尝试为我的过滤器上的每个条件（我至少有 1000 个条件）创建一个循环。 例如：对于过滤器（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

我意识到这是不久前被问到的，但我还没有看到任何我认为可以复制粘贴的东西。这是我想出的。它应该适用于无限的标准。它确实创建了一个名为“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

Answer 2

这对我有用

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