CODEWITHSUNDEEP
excelvbafiltercriteria
Arthur Henrique Andrade da Sil
Arthur Henrique Andrade da Sil

Reputation: 11

Loop through filter criteria

I've been trying to figure this out but no progress...

I have a filter (COLUMN D) and I'm trying to create a loop to each criteria (I got at least 1000 criterias) on my filter. Ex: For each criteria on filter (column D), I'll run a range copy...

That code isnt working at all:

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

My mistake seems to be identifying my filter column...

Upvotes: 0

Views: 16418

Answers (2)

christodorov
christodorov

Reputation: 111

I realize this was asked a while ago but I havent seen anything that I consider copy-paste ready. here is what I came up with. It should work for unlimited criteria. It does create a single new sheet called "temp" that can be deleted once finished. 

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

Upvotes: 2

PeterT
PeterT

Reputation: 8557

This worked for me

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

Upvotes: 2

Related Questions