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

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

名称范围为图纸“查找”范围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

---

你可以试试这样的

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

---

您可能可以避免所有这些，并使用

PivotTable.ShowPages方法

。它针对这种操作进行了优化

---

注意：

“所有者：全名”

必须位于顶部的页面字段区域中

您可能需要检查工作表名称是否不存在。您可以对将从pivot生成的工作表名称执行初始循环，并尝试删除它们（在错误恢复时包装在

，然后在错误转到0时尝试删除），以确保它们首先不存在。我已经在第二个例子中展示了如何做到这一点

---

信息：

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

语法表达式。显示页面（页面字段）

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

[页面字段的可选参数。]

---

代码：

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

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

---

这将为页面字段

“所有者：全名”

中的每个可能值生成一张表。如果不需要所有工作表，只需将工作表的工作表名称列表保存在一个数组中，并循环工作簿中的所有工作表，如果不在数组中，则按如下所示删除：

① 循环工作表和删除（如果不在阵列中）的示例：

---

运行示例：

---

为使查找范围动态，请考虑使用该属性。你不是指

ws2.Name

，而不是

ws1

？最后，您目前有哪些错误？您好，谢谢。然而，它似乎并没有完全起作用。在运行过程中，它似乎卡在了“If Err=0 Then”上，并且它一直跳过创建新工作表并粘贴到。。。有什么想法吗？如果在透视字段中找不到项目，

PTF.CurrentPage=rng.Value

将抛出错误。若并没有错误，那个就意味着找到了项目，将添加一个新的工作表，并将数据透视表范围复制到其中。只需在错误转到0时添加另一行

，就在该行
Set ws2=Nothing
之后，这将重置错误处理程序。已尝试此操作。仍然不起作用，在尝试查找范围中的值时出现错误（尽管它查找的范围有98行，它们与轴值相同）。想法？什么不起作用？是否不为某些项目创建新图纸？如果是，请确保这些项目与ws1上B列中的项目完全相同。检查前导或尾随空格。否则，我看不到代码中有任何问题。或者尝试使用
F8
键调试代码，查看代码在何处跳过创建新工作表，然后检查
rng.Value
，并将其与页面字段中的项目进行比较，看它们是否完全相同。您好，我认为这很有效。然而，对于我来说，它直接跳到了错误，因为“所有者：全名”不是一个透视页面。所以它找不到里面的项目。如果字段不是页面，我可以如何使用它？除非在页面字段中，否则它不会工作。不能在页面字段中使用吗？另一种方法是在该字段的任何位置循环，选择项目。请记住，您可以在另一张图纸中创建一个重复的轴，并将其放在页面字段中，如果您希望保留其现有布局的原始轴，则可以使用该轴生成图纸。确保代码指向重复的轴心。我现在工作得很好。非常感谢。只是稍微调整了一下，现在效果很好！
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