2

我想知道是否有一种方法可以在列表中获取所有不同的自动过滤条件，以便遍历每个条件，最后复制并粘贴每个不同的表，这些表在迭代时会出现在单独的工作表中。

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

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

其中 n 是存在的不同 CritVariables 的数量。

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

4

3 回答 3

1

您可以学习和调整以下内容。这是正在发生的事情的概述。

  • 我有一个从单元格 A5 开始的人员表，在 G 列中有一个办公室列表；
  • 我正在从 G5 向下复制（假设此列的数据中没有空白）到 W1；
  • 从 W1 范围向下，我正在删除重复项；
  • 然后我遍历这些数据，使用高级过滤器将每个办公室的数据复制到从单元格 Z1 开始的区域；
  • 然后将过滤后的数据移动（剪切）到一个新的工作表中，该工作表以当前的办公室名称（标准）命名；
  • 在每个高级过滤器之后，单元格 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

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

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

补充：嗯，我也受到了启发，用 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

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

于 2013-06-20T19:12:59.693 回答
1

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

于 2015-05-18T17:52:28.307 回答
1

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

'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
于 2015-12-01T18:41:37.457 回答