在 vba 中一次一个地循环所有可用的自动过滤条件

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

提问by Ganksy

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:

理想情况下，这将运行 n 次：

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

Where n is the number of different CritVariables there are.

其中 n 是不同 CritVariables 的数量。

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?

我想强调的是，我知道如何在宏本身中复制和粘贴，但我很好奇如何遍历所有不同的标准，因为标准可能因日期而异。如果它的列表不可用，我将如何最好地遍历标准？

采纳答案by Andy G

You can study and adaptthe 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 Filterto 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.

• 我有一个从单元格 A5 开始的员工表，在 G 列中有一个办公室列表；
• 我正在从 G5 向下复制（假设此列的数据中没有空格）到 W1；
• 从范围 W1 向下，我正在删除重复项；
• 然后我循环遍历这些数据，使用高级过滤器将每个办公室的数据复制到从单元格 Z1 开始的区域；
• 然后将此过滤后的数据移动（剪切）到一个新的工作表，该工作表以当前办公室名称（条件）命名；
• 每次高级过滤后，单元格 W2 被删除，使 W3 中的值向上移动，以便它可以用于下一次过滤操作。

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 ;).

这确实意味着当您按 Ctrl-End 转到上次使用的单元格时，它会比需要的更远。如有必要，您可以找到解决此问题的方法；)。

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 ;) ).

顺便说一句，我不打算为您的特定文件修改它；这是你应该做的事情（或付钱给别人做；））。

BTWIt 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:

补充：嗯，我也觉得用 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

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

[可以使用定义的名称和一些错误处理/检查来改进这两个过程。]

回答by Federico Sanchez

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

如果您愿意，您可以构建一个新集合，该集合将只有唯一值的数组，然后循环遍历它们。你会知道每个

回答by Schalton

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