VBA-循环数据透视表筛选提取

下面的代码将过滤器应用于数据透视表，然后从数据透视表复制特定数据并删除过滤器。。问题是，这一块代码使用了22次，子代码太长了

以下是我仅有的一个代码块的代码：

    Option Explicit

        Sub FilterPivotTable()

        Dim rLastCell As Range
        Dim PvtTbl As PivotTable
        Dim ws1 As Worksheet, ws2 As Worksheet
        Dim LastRow1 As Long
        Set ws1 = ActiveWorkbook.Sheets("PivotTable")
        Set ws2 = ActiveWorkbook.Sheets("Summary")
        Dim rowCount As Long

            LastRow1 = ws1.Cells(Rows.Count, 1)

            'Microsoft Windows
            Application.ScreenUpdating = False

            ws1.PivotTables("P1").ManualUpdate = True

            ws1.PivotTables("P1").PivotFields(" Vulnerability Name").ClearAllFilters

    '---------------Block Starts Here---------------

            ws1.PivotTables("P1").PivotFields(" Vulnerability Name").PivotFilters. _
            Add Type:=xlCaptionContains, Value1:="Microsoft Windows"

            ws1.PivotTables("P1").ManualUpdate = False
            Application.ScreenUpdating = True

            With ws1.PivotTables(1).TableRange1
                Set rLastCell = .Cells(.Rows.Count, .Columns.Count)
                Set PvtTbl = Worksheets("PivotTable").PivotTables("P1")
                rLastCell.Copy

                With ws2

                    .Cells(LastRow1 + 2, 3).PasteSpecial xlPasteValues
                    .Range("$B$2").Value = "Microsoft Windows"

                    rowCount = PvtTbl.DataBodyRange.Rows.Count
                    .Range("$D$2") = rowCount - 1

                End With

            End With

            ws1.PivotTables("P1").PivotFields(" Vulnerability Name").ClearAllFilters

'---------------Block Ends Here---------------

        End Sub

此代码块在此子模块中重复22次，每次仅更改漏洞名称，即将'Microsoft Windows'更改为'Adobe'，然后更改要将数据复制到摘要表中的单元格引用

我更希望有一个代码块循环通过漏洞名称，而不是有22个不同的代码块执行相同的功能

这就是透视表结构的外观：

---

过滤器是在rows块下完成的，在漏洞名称上完成的。我担心这有点像是在暗箱操作

Option Explicit

Sub FilterPivotTable()

    Dim rLastCell As Range
    Dim PvtTbl As PivotTable
    Dim ws1 As Worksheet, ws2 As Worksheet

    Set ws1 = ActiveWorkbook.Sheets("PivotTable")
    Set ws2 = ActiveWorkbook.Sheets("Summary")

    Dim rowCount As Long
    Dim LastRow1 As Long
    Dim pvtField As PivotField

    Set PvtTbl = ws1.PivotTables("P1")

    Application.ScreenUpdating = False

    Set pvtField = PvtTbl.PivotFields(" Vulnerability Name") 'extend etc as required

    Dim myArr()
    myArr = Array("Microsoft Windows", "Adobe Reader", "Other")

    'PvtTbl.ManualUpdate = False

    Dim i As Long

    For i = LBound(myArr) To UBound(myArr)

        pvtField.ClearAllFilters
        pvtField.PivotFilters. _
        Add Type:=xlCaptionContains, Value1:=myArr(i)

        With ws1.PivotTables(1).TableRange1
            Set rLastCell = .Cells(.Rows.count, .Columns.count) 'grand total?
        End With

        With ws2
            LastRow1 = ws2.Cells(ws2.Rows.count, 3).End(xlUp).row
            rLastCell.Copy
            .Cells(LastRow1 + 1, 3).PasteSpecial xlPasteValues
            .Cells(LastRow1 + 1, 2).Value = myArr(i)
            rowCount = PvtTbl.DataBodyRange.Rows.count
            .Cells(LastRow1 + 1, 4) = rowCount - 1
        End With

    Next i

    Application.ScreenUpdating = True
    'PvtTbl.ManualUpdate = False
End Sub

---

因此，您正在尝试更改ws1.PivotTables（“P1”）.PivotFields（“漏洞名称”）.PivotFilters添加类型：=xlCaptionContains，值1:=“Microsoft Windows”？@QHarr是，正在尝试将“Microsoft Windows”更改为“Adobe Reader”，并在With语句中再次出现特定单元格引用-这也需要为每个筛选器增加一个增量。。因此，MS Windows将粘贴在前3列的第一行，然后adobe将粘贴在下一行，然后MS Office将粘贴在下一行，依此类推。是否要在数据透视字段中循环所有项目？这是显而易见的事情，即使你只追求几项。另外，要小心With语句中的With语句。@QHarr第二个选择你是个天才！这是伟大的工作！哇！有三件事我只想知道：1）在汇总表上，每次粘贴后，它跳过一行，然后粘贴下一个过滤数据2）当我在汇总表上时，该表不会更新，我需要单击另一张表，当我返回汇总表时，它已被更新3）您对“总计”的评论没错，我现在会更新答案。对于1）您只需将.Cells（LastRow1+2,3）更改为.Cells（LastRow1+1,3）etcTbh，正如Rado先生所指出的，这可以更好地进行编码。所以我为你们改变了第一点。第二点我不知道为什么。我已经为PvtTbl.ManualUpdate注释掉了你的两行，如果没有差异，你可以再次取消注释。谢谢你，这太完美了。你注释掉的行不起作用，但很好。我很高兴，非常感谢你的帮助！谢谢：）那就祝你快乐吧