VBA - 循环透视过滤器中的每个项目并粘贴到新工作表中

Question

我有一个挑战...我在工作表查找中有一个范围，其中每个可能的值都在数据透视表过滤器“所有者：全名”中。

具有名称的范围是工作表“查找”范围 B2:B98。 （问题1：这个范围可以改变，因为它在不同的代码中创建这个列表，如何将它设置为一个动态范围？）

一旦过滤该值，即 B2 中的值，它应该将此过滤后的枢轴复制到新工作表中，并以 b2 中的值命名工作表。

然后它应该“取消选择” b2 项目并去过滤 b3 中的值并继续。

问题 2：正确设置过滤器以循环和过滤新动态查找范围中的每个单个值。

这是我目前所拥有的......

Option Explicit

    Dim wb As Workbook, ws, ws1, ws2 As Worksheet, PT As PivotTable, PTI As 
    PivotItem, PTF As PivotField, rng As Range

    Sub Filter_Pivot()

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Copy")
    Set ws1 = wb.Sheets("Lookup")
    Set PT = ws.PivotTables("PivotCopy")
    Set PTF = PT.PivotFields("Owner: Full Name")


        For Each rng In ws1.Range("B2:B98")
            With PTF
                .ClearAllFilters
                For Each PTI In PTF.PivotItems
                    PTI.Visible = (PTI.Name = rng)
                Next PTI
            Set ws2 = Sheets.Add
                ws1.Name = PTI
                .TableRange2.Copy
                ws2.Range("A1").PasteSpecial
            End With
        Next rng


    End Sub

Answer 1

您也许可以避免这一切并使用PivotTable.ShowPages Method。它针对这种操作进行了优化。

---

注意：

1. "Owner: Full Name" 必须位于顶部的页面字段区域中。
2. 您可能想要检查工作表名称是否不存在。您可以执行将从数据透视生成的工作表名称的初始循环并尝试删除它们（包装在On Error Resume Next, attempt delete, On Error GoTo 0 中）以确保它们首先不存在。我已经在第二个例子中展示了如何做到这一点。

---

信息： PivotTable.ShowPages Method

为页面字段中的每个项目创建一个新的数据透视表。每个 在新工作表上创建新报告。

语法表达式。 ShowPages(PageField)

表达式 表示数据透视表对象的变量。

[pageField的可选参数]

---

代码：

ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "Owner: Full Name"

---

这将为页面字段"Owner: Full Name" 中的每个可能值生成一个工作表。如果您不想要所有这些，只需将要保留的工作表名称列表保存在一个数组中，然后遍历工作簿中的所有工作表，如果不在数组中，则删除，如下所示：

①循环工作表，如果不在数组中则删除示例：

Option Explicit

Public Sub GeneratePivots()
    Dim keepSheets(), ws As Worksheet
    keepSheets = Array("FilterValue1", "FilterValue2","Lookup","Copy") '<== List of sheet names to keep

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error GoTo errHand

    ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "Owner: Full Name"

    For Each ws In ThisWorkbook.Worksheets
        If IsError(Application.Match(ws.Name, keepSheets, 0)) And ThisWorkbook.Worksheets.Count > 1 Then
            ws.Delete
        End If
    Next ws

errHand:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

---

② 使用查找表：

如果您仍想阅读表格以避开Copy 表格，那么您可以使用以下内容（但请务必在 B 列的列表中包含表格名称 @ 987654331@,Lookup，感兴趣的过滤器值，以及您不想删除的任何其他工作表名称）：

代码：

Option Explicit

Public Sub GeneratePivots()
    Dim ws As Worksheet, lookups As Range

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    With ThisWorkbook.Worksheets("Lookup")
        Set lookups = .Range(.Range("B2"), .Range("B2").End(xlDown))
        If Application.WorksheetFunction.CountA(lookups) = 0 Then Exit Sub
        keepSheets = lookups.Value
    End With

    Dim rng As Range
    For Each rng In lookups
        On Error Resume Next
         Select Case rng.Value
         Case "Lookup", "Copy" '<=Extend for sheets to keep listed in lookups that aren't generated by the pivot filtering
         Case Else
             ThisWorkbook.Worksheets(rng.Value).Delete
         End Select
        On Error GoTo 0
    Next rng

   On Error GoTo errHand

    ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "Owner: Full Name"

    For Each ws In ThisWorkbook.Worksheets
        If IsError(Application.Match(ws.Name, Application.WorksheetFunction.Index(keepSheets, 0, 1), 0)) And ThisWorkbook.Worksheets.Count > 1 Then
            ws.Delete
        End If
    Next ws

errHand:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

---

示例运行：

Answer 2

你可以试试这样的……

Sub Filter_Pivot()
Dim wb As Workbook
Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
Dim PT As PivotTable
Dim PTF As PivotField
Dim rng As Range
Dim lr As Long

Set wb = ThisWorkbook
Set ws = wb.Sheets("Copy")
Set ws1 = wb.Sheets("Lookup")
Set PT = ws.PivotTables("PivotCopy")
Set PTF = PT.PivotFields("Owner: Full Name")

lr = ws1.Cells(Rows.Count, 2).End(xlUp).Row

For Each rng In ws1.Range("B2:B" & lr)
    PTF.ClearAllFilters
    On Error Resume Next
    PTF.CurrentPage = rng.Value
    If Err = 0 Then
        Set ws2 = Sheets(rng.Value)
        ws2.Cells.Clear
        If ws2 Is Nothing Then
            Set ws2 = Sheets.Add
            ws2.Name = rng.Value
        End If
        PT.TableRange2.Copy ws2.Range("A1")
    End If
    PTF.ClearAllFilters
    Set ws2 = Nothing
    On Error GoTo 0
Next rng
End Sub