Question

我想知道是否有办法在列表中获取所有不同的自动筛选条件以迭代每个条件，最后复制并粘贴每个不同的表格一个单独的表格，它迭代通过。

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

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

其中n是不同CritVariables的数量。

我想强调我知道如何复制和粘贴宏本身，但我很好奇如何迭代所有不同的标准，因为标准可能因日而异。如果没有可用的列表，我最好如何迭代标准？

Answer 1

您可以学习并适应以下内容。以下是正在发生的事情的概述。

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

这确实意味着当您按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我不打算为你的特定文件修改它;这是你应该做的事情（或付某人去做;））。

BTW 可以使用普通（而不是高级）过滤器来完成。您仍然可以复制列并删除重复项。这样做的好处是不会过多地增加工作表的表观大小。但我决定这样做;）。

已添加：我也感受到了使用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

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

Answer 2

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

Answer 3

我知道它已经很晚了，你已经选择了一个答案，但我正在开展一个涉及数据透视表的类似项目，并决定这样做：

'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

在vba中一次循环一次所有可用的自动过滤器标准

3 个答案: