基於列中的值的循環數據透視表過濾器

Question

對此非常陌生，但我將嘗試使我的問題更易於理解。

我有一個帶有數據透視表的Excel工作表，我先對第一列（銷售人員姓名）進行過濾，然后將過濾后的數據透視表復制粘貼到新工作表中，並將其另存為銷售人員姓名。

是否可以使宏根據表（Table1）中的值循環通過第一列過濾器，然后將值復制到新工作表中？ 宏的示例將很有幫助。

更新-我已經在某種程度上進行了一些管理，但是它正在復制數據透視表批發，然后嘗試每行保存一個文件。

Sub Gen()

Dim PvtTbl As PivotTable
Set PvtTbl = ActiveSheet.PivotTables("PivotTable1")
Dim Field As PivotField
Set Field = ActiveSheet.PivotTables("PivotTable1").PivotFields("SPerson")
Dim PvtItm As PivotItem
Dim Range As Range
Dim i As Long
Dim var As Variant


Application.ScreenUpdating = False


For Each PvtItm In Field.PivotItems
    ActiveSheet.Range("$A$11").Select
    Selection.CurrentRegion.Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    ActiveWorkbook.SaveAs ("C:\" & ActiveSheet.Range("$B$2") & Format(Date, "yyyy - mm") & ".xlsx")
Next PvtItm


Application.ScreenUpdating = True


End Sub`

其中$ A $ 11是數據透視表，$ B $ 2是我要將文件另存為的銷售人員的姓名。

Answer 1

2個版本：

版本1，使用循環來選擇可透視表項。

版本2使用數據.ShowPages方法。

我猜方法1應該更有效。

在最初的幾次運行中，沒有其他任何運行，我很驚訝地發現.ShowPages更快。 平均2.398秒，與第1版，歷時3.263秒。

警告：這只是時序的幾次測試，由於我的編碼可能會有差異，但是也許值得探討？ 沒有使用其他優化方法。 當然，還有其他可能。

版本1：

Option Explicit
Sub GetAllEmployeeSelections()

    Const filePath As String = "C:\Users\User\Desktop\" 'save location for new files

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim pvt As PivotTable

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet3")
    Set pvt = ws.PivotTables("PivotTable1")

    Application.ScreenUpdating = False

    Dim pvtField As PivotField
    Dim item As Long
    Dim item2 As Long

    Set pvtField = pvt.PivotFields("SPerson")

    For item = 1 To pvtField.PivotItems.Count

          pvtField.PivotItems(item).Visible = True

          For item2 = 1 To pvtField.PivotItems.Count

              If item2 <> item Then pvtField.PivotItems(item2).Visible = False

          Next item2

        Dim newBook As Workbook
        Set newBook = Workbooks.Add

        With newBook

            Dim currentName As String
            currentName = pvtField.PivotItems(item).Name

            .Worksheets(1).Name = currentName

            pvt.TableRange2.Copy

            Worksheets(currentName).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

           .SaveAs Filename:=filePath & currentName & ".xlsx"

           .Close

        End With

        Set newBook = Nothing

    Next item

    Application.ScreenUpdating = True

End Sub

版本2：

為什么不利用PivotTable的.ShowPages方法並將sPerson作為頁面字段參數呢？ 它循環指定的pagefield並為每個項目生成具有該項目值的工作表。 然后，您可以再次循環字段項目，並將數據導出到新工作簿，保存，然后刪除創建的工作表。

可能有點矯kill過正！

PivotTable.ShowPages方法（Excel）

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

句法

表達。 ShowPages（PageField）

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

碼：

 Option Explicit
'Requires all items selected

Sub GetAllEmployeeSelections2()

    Const filePath As String = "C:\Users\User\Desktop\" 'save location for new files

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim pvt As PivotTable

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet3")
    Set pvt = ws.PivotTables("PivotTable1")

    Application.ScreenUpdating = False

    Dim pvtField As PivotField
    Dim item As Variant

    Set pvtField = pvt.PivotFields("SPerson")

    pvtField.ClearAllFilters
    pvtField.CurrentPage = "(All)"

     For Each item In pvtField.PivotItems
        item.Visible = True
     Next item

    pvt.ShowPages "Employee"

    For Each item In pvtField.PivotItems

        Dim newBook As Workbook
        Set newBook = Workbooks.Add

        With newBook

            .Worksheets(1).Name = item.Name

            wb.Worksheets(item.Name).UsedRange.Copy

            Worksheets(item.Name).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

           .SaveAs Filename:=filePath & item.Name & ".xlsx"

           .Close

        End With

        Set newBook = Nothing

    Next item

    Application.DisplayAlerts = False

    For Each item In pvtField.PivotItems

         wb.Worksheets(item.Name).Delete

    Next item

    Application.DisplayAlerts = True

    Application.ScreenUpdating = True

End Sub