在vba中一次一个循环地使用所有可用的自动筛选器标准
我想知道是否有办法在列表中获取所有不同的自动筛选标准，以便遍历每个标准 ，最后复制并粘贴每个不同的表格，当它遍历时，它们将显示在单独的表格中。
理想情况下，这将运行n次：
ActiveSheet.Range(AllRows).AutoFilter Field:=10, Criteria1:=CritVariable 其中n是不同的CritVariables的数量。
我想强调，我知道如何复制和粘贴macros本身，但我很好奇如何遍历所有不同的标准，因为标准可能会有所不同，这取决于一天。 如果它的列表不可用，我将如何最好地去遍历标准？
你可以学习和适应以下内容。 这里是正在发生的事情的大纲。
- 我有一个从单元格A5开始的工作人员表，列G中有一个办公室的名单;
- 我从G5向下复制（假设这一列的数据没有空白）到W1;
- 从范围W1向下，我删除重复 ;
- 然后我循环这些数据，使用高级filter将每个办公室的数据复制到从单元格Z1开始的区域;
- 这个过滤的数据然后被移动（剪切）到一个新的工作表，这是从当前的办公室名称（条件）命名的;
- 在每个高级filter之后，单元格W2被删除，使得W3中的值上移，以便它可以用于下一个filter操作。
这意味着当你按下Ctrl-End去到最后使用的单元格时，它会比需要的更进一步。 如有必要，您可以find一种解决方法;）。
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
顺便说一句，我不打算修改你的具体文件， 这是你应该做的事情（或者付钱给别人做）;）。
顺便说一句，它可以使用正常（而不是高级）filter来完成。 您仍然可以复制该列并删除重复项。 这样做的好处是不会太多地增加工作表的外观尺寸。 但我决定这样做;）。
补充一点 ：好吧，我觉得用AutoFilter也能达到这个目的：
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
[这两个过程可以使用定义名称和一些error handling/检查来改进。]
如果你想要的话，你可以build立一个新的集合，它将有一个唯一值的数组，然后遍历它们。 你会知道每一个
我知道已经很晚了，你已经select了一个答案，但是我正在做一个涉及数据透视表的类似项目，并决定这样做：
'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