VBA- 循環數據透視表中的每個項目並粘貼到新工作表中 - VBA - Loop Each Item in Pivot Filter and Paste into new sheet -开发者知识库

VBA- 循環數據透視表中的每個項目並粘貼到新工作表中 - VBA - Loop Each Item in Pivot Filter and Paste into new sheet -开发者知识库,第1张

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

我有一個挑戰...我在Sheet Lookup中有一個范圍,其中每個可能的值都在數據透視表過濾器“Owner:Full Name”中。

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?)

名稱范圍是Sheets“Lookup”Range B2:B98。 (問題1:此范圍可以更改,因為它在不同的代碼中創建此列表,如何將其設置為動態范圍?)

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中的那個值,它應該將這個過濾的樞軸復制到一個新的工作表中,並將該工作表命名為b2中的值。

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

然后它應該“取消選擇”b2項目並繼續過濾b3中的值並繼續。

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

問題2:正確設置過濾器以循環並過濾新動態查找范圍中的每個單獨值。

Here is what I have at the moment...

這就是我現在所擁有的......

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

2 个解决方案

#1


2  

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

您可以避免所有這些並使用PivotTable.ShowPages方法。它針對此類操作進行了優化。


Note:

  1. "Owner: Full Name" must be in the page field area at the top.
  2. “所有者:全名”必須位於頂部的頁面字段區域中。

  3. 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.
  4. 您可能想要檢查工作表名稱是否尚不存在。您可以執行將從pivot生成的工作表名稱的初始循環並嘗試刪除它們(包含在On Error Resume Next,嘗試刪除,On Error GoTo 0)以確保它們不存在。我在第二個例子中展示了如何做到這一點。


Info: PivotTable.ShowPages Method

信息:PivotTable.ShowPages方法

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

為頁面字段中的每個項目創建新的數據透視表。每個新報告都在新工作表上創建。

Syntax expression . ShowPages( PageField )

語法表達式。 ShowPages(PageField)

expression A variable that represents a PivotTable object.

expression表示數據透視表對象的變量。

[Optional parameter of pageField.]

[pageField的可選參數。]


Code:

ThisWorkbook.Worksheets("Copy").PivotTables("PivotCopy").ShowPages "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:

這將在頁面字段“Owner:Full Name”中為每個可能的值生成一個工作表。如果您不想要所有這些,只需保存要保留的工作表的工作表名稱列表,在數組中,並循環工作簿中的所有工作表,如果不在數組中,則刪除如下所示:

① Example of looping sheets and deleting if not in array:

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

② 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):

如果您確實仍希望讀取工作表以保留復制工作表,則可以使用以下內容(但請確保在B列的列表中包含工作表名稱復制,查找,感興趣的過濾器值以及任何其他您不想刪除的工作表名稱):

Code:

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- 循環數據透視表中的每個項目並粘貼到新工作表中 - VBA - Loop Each Item in Pivot Filter and Paste into new sheet -开发者知识库,Test run,第2张

最佳答案:

本文经用户投稿或网站收集转载,如有侵权请联系本站。

发表评论

0条回复