遍歷過濾條件

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

這爲我工作

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