Looping through all available autofilter criteria one at a time in vba

Question

I was wondering if there was a way to get all the different autofilter criteria in a list in order to iterate through each criteria, to in the end copy and paste each different table that would appear to a separate sheet as it iterates through.

Ideally this would be run n times:

ActiveSheet.Range(AllRows).AutoFilter Field:=10, Criteria1:=CritVariable

Where n is the number of different CritVariables there are.

I'd like to stress that I know how to copy and paste in the macro itself, but I was curious how to iterate through all the different criteria because the criteria could be different depending on the day. If a list of it isn't available how would I best go about iterating through the criteria?

Answer 1

I know it's late and you've already selected an answer, but I'm working on a similar project involving a pivot table and decided to do it this way:

'Here I'm Filtering a column of Week numbers to get rid of non-numbers
'From a pivot table

'I select sheet where my underlying pivot data is located and establish the range
'My data is in column 2 and it ends after "DSLastRow" Rows starting at Row 2

Sheets("DataSheet").Select
DSLastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

'I create and redim an array that is large enough to hold all of the data in the range
Dim FilterCriteria(): RedimFilterCriteria(1 To DSLastRow)

For r = 2 To DSLastRow 'r for row / my data has a header in row 1
    If Cells(r, 2).Value <> "" Then 'again, starting in column B (2)
        'Check if it's already in the FilterCriteria Array
        For CheckFCA = 1 To r
            'Jumps to next row if it finds a match
            If FilterCriteria(CheckFCA) = Cells(r, 2).Value Then GoTo Nextr
            'Saves the value and jumps to next row if it reaches an empty value in the array
            If IsEmpty(FilterCriteria(CheckFCA)) Then
                FilterCriteria(CheckFCA) = Cells(r, 2)
                GoTo Nextr
            End If
        Next CheckFCA
    End if
Nextr:
Next r
'At this point FilterCriteria() is filled with all of the unique values

'I'm filtering a pivot table which is why I created the unique array from
'the source data, but you should be able to just loop through the table
Sheets("Pivot").Select
ActiveSheet.PivotTables("ReportPivot").PivotFields("Week").ClearAllFilters
With ActiveSheet.PivotTables("ReportPivot").PivotFields("Week")
    For FilterPivot = 1 To DSLastRow
        'I'm filtering out all non-numeric items
        If IsEmpty(FilterCriteria(FilterPivot)) Then Exit For
        If Not IsNumeric(FilterCriteria(FilterPivot)) Then
            .PivotItems(FilterCriteria(FilterPivot)).Visible = False
        End If
    Next FilterPivot
End With

Answer 2

if you want you can build a new collection which will have an array of only unique values and then loop over them. you will know that each

Answer 3

You can study and adapt the following. Here is an outline of what is going on.

• I have a staff-table starting at cell A5, with a list of Offices in column G;
• I'm copying from G5 downwards (assuming there are no blanks in this column's data) to W1;
• From range W1 downwards I am removing duplicates;
• Then I'm looping through this data, using Advanced Filter to copy the data for each office to an area starting at cell Z1;
• This filtered data is then moved (Cut) to a new worksheet, which is named from the current Office name (the criteria);
• After each Advanced Filter the cell W2 is deleted, making the value in W3 move up, so that it can be used for the next filter operation.

This does mean that when you press Ctrl-End to go to the last-used cell it goes further than it needs to. You can find a way to resolve this if necessary ;).

Sub SheetsFromFilter()
    Dim wsCurrent As Worksheet
    Dim wsNew As Worksheet
    Dim iLeft As Integer

    Set wsCurrent = ActiveSheet
    Application.ScreenUpdating = False
    Range("G5", Range("G5").End(xlDown)).Copy Range("W1")
    Range("W1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
    iLeft = Range("W1").CurrentRegion.Rows.Count - 1
    Do While iLeft > 0
        wsCurrent.Range("A5").CurrentRegion.AdvancedFilter xlFilterCopy, _
            wsCurrent.Range("W1:W2"), wsCurrent.Range("Z1")
        Set wsNew = Worksheets.Add
        wsCurrent.Range("Z1").CurrentRegion.Cut wsNew.Range("A1")
        wsNew.Name = wsCurrent.Range("W2").Value
        wsCurrent.Range("W2").Delete xlShiftUp
        iLeft = iLeft - 1
    Loop
    wsCurrent.Range("W1").Clear
    Application.ScreenUpdating = True
End Sub

BTW I don't intend to modify this for your specific file; this is something that you should do (or pay someone to do ;) ).

BTW It could be done using the normal (rather than Advanced) Filter. You would still copy the column and remove duplicates. This would have the benefit of not increasing the apparent size of the worksheet too much. But I decided to do it this way ;).

Added: Well, I felt inspired to achieve this with AutoFilter as well:

Sub SheetsFromAutoFilter()
    Dim wsCurrent As Worksheet
    Dim wsNew As Worksheet
    Dim iLeft As Integer

    Set wsCurrent = ActiveSheet
    Application.ScreenUpdating = False
    Range("G5", Range("G5").End(xlDown)).Copy Range("W1")
    Range("W1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
    iLeft = Range("W1").CurrentRegion.Rows.Count - 1
    Do While iLeft > 0
        Set wsNew = Worksheets.Add
        With wsCurrent.Range("A5").CurrentRegion
            .AutoFilter field:=7, _
                Criteria1:=wsCurrent.Range("W1").Offset(iLeft).Value
            .Copy wsNew.Range("A1")
            .AutoFilter
        End With
        wsNew.Name = wsCurrent.Range("W1").Offset(iLeft).Value
        iLeft = iLeft - 1
    Loop
    wsCurrent.Range("W1").CurrentRegion.Clear
    Application.ScreenUpdating = True
End Sub

[Both procedures could be improved using Defined Names and some error handling/checking.]