VBA-将数据透视过滤器中的每个项目循环并粘贴到新工作表中 [英] VBA - Loop Each Item in Pivot Filter and Paste into new sheet

问题描述

我面临挑战...我在工作表查找中有一个范围，数据透视表过滤器所有者:全名"中的每个可能值.

I have a challenge... I have a range in Sheet Lookup with each possible value in Pivot table filter "Owner: Full Name".

名称范围为图纸查找"范围B2:B98. (问题1:在使用不同代码创建此列表时，该范围可能会发生变化，如何将其设置为动态范围?)

The range with the names are Sheets "Lookup" Range B2:B98. (Problem 1: This range can change as it creates this list in a different code, how to set this to a dynamic range?)

一旦对其进行过滤(即B2中的值)，则应将此过滤后的数据透视表复制到新工作表中，并以b2中的值命名工作表.

Once it filters on that i.e. value in B2 it should copy this filtered pivot into a new sheet and name the sheet after the value in b2.

然后，它应该取消选择" b2项，并根据b3中的值进行过滤，然后继续.

Then it should "deselect" the b2 item and go to filter on value in b3 and continue.

问题2:正确设置过滤器以循环并根据新的动态查找范围中的每个单个值进行过滤.

Problem 2: Setting the filter correctly to loop and filter on each single value in the new dynamic lookup range.

这是我现在的...

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

推荐答案

您也许可以避免所有这些，而使用PivotTable.ShowPages Method.针对此类操作进行了优化.

You might be able to avoid all this and use the PivotTable.ShowPages Method. It is optimized for this sort of operation.

注意:

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

1. "Owner: Full Name" must be in the page field area at the top.
2. You probably want to check the sheet names don't already exist. You could do an initial loop of sheet names that will be generated from pivot and try deleting them (wrapping inside an On Error Resume Next, attempt delete, On Error GoTo 0) to ensure they don't exist first. I have shown how to do this in the second example.

---

信息:

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

Creates a new PivotTable report for each item in the page field. Each new report is created on a new worksheet.

语法表达式. ShowPages(PageField)

Syntax expression . ShowPages( PageField )

expression一个表示数据透视表对象的变量.

expression A variable that represents a PivotTable object.

[pageField的可选参数.]

[Optional parameter of pageField.]

---

代码:

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

---

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

---

This will produce a sheet for each possible value in the page field "Owner: Full Name". If you don't want all of them, simply hold a list of sheet names for sheets to keep, in an array, and loop over all sheets in workbook and if not in array then delete as shown below:

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列的列表中包含表单名称Copy，Lookup，感兴趣的过滤器值以及您不想删除的任何其他工作表名称):

---

② Using a lookup sheet:

If you do want to still read in the sheets to keep from the Copy sheet then you can use the following (but be sure to include in the list in column B the sheet names Copy,Lookup, the filter values of interest, and any other sheet names you don't want deleted):

代码:

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

---

示例运行:

---

Example run:

这篇关于VBA-将数据透视过滤器中的每个项目循环并粘贴到新工作表中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！