循环筛选条件

我一直在想这个，但没有进展…

我有一个filter（COLUMN D），我试图创build一个循环到我的filter上的每个标准（我至less有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 

我的错误似乎是确定我的filter列…

Answer 1

我意识到这是前不久，但我没有看到任何我认为复制粘贴准备。 这是我想出来的。 它应该为无限的标准工作。 它确实创build了一个名为“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