基于列中的值的循环数据透视表过滤器

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 并为每个具有该项目值的项目生成一个工作表。然后，您可以再次循环字段项并将数据导出到新工作簿，保存，然后删除创建的工作表。

这可能有点矫枉过正！

PivotTable.ShowPages Method (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