vba - 在vba中一次循环遍历所有可用的自动筛选条件

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

顺便说一句，我不打算针对您的特定文件修改它；这是你应该做的事情(或者花钱请人去做；))。

顺便说一句可以使用普通(而不是高级)过滤器来完成。您仍然需要复制该列并删除重复项。这样做的好处是不会过多地增加工作表的表观大小。但我决定这样做;)。

添加:好吧，我也受到了使用自动筛选来实现这一目标的启发:

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

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