Looping through all available autofilter criteria one at a time in vba - 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

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.]

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

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