尝试使用 vba 将过滤器添加到枢轴

Question

我正在尝试在数据透视表上运行 vba，因为我需要为我的报告更新 50 多个表，这只有在我可以使用 vba 执行此操作时才能节省时间。

使用 vba，我可以将数据透视表中的结果直接复制到同一工作簿的另一张工作表的单元格中。我在尝试添加过滤器时遇到了困难。

我能够运行获得摘要信息的第一部分，现在我正在尝试添加 "Revised Territory" 过滤器，我想过滤 "SE" 然后它什么也没做。

我使用 F8 进行检查，看起来它只是通过而没有任何错误，但没有添加任何过滤器，所以我得到了与我的摘要数据相同的信息.

我的代码

Sub InsertPivotTable()

''''''''''''''''''
'''Pivot Set Up'''
''''''''''''''''''
'Declare Variables
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim SSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PRange As Range
Dim LastRow As Long
Dim LastCol As Long

'Insert a New Blank Worksheet
On Error Resume Next

Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "PivotTable"
Application.DisplayAlerts = True
Set PSheet = Worksheets("PivotTable")
Set DSheet = Worksheets("PIF Data")
Set SSheet = Worksheets("Summary")

'Define Data Range
LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = 76
Set PRange = DSheet.Cells(1, 1).Resize(LastRow, LastCol)

'''''''''
'Summary'
'''''''''
'Define Pivot Cache
Set PCache = ActiveWorkbook.PivotCaches.Create _
    (SourceType:=xlDatabase, SourceData:=PRange). _
    CreatePivotTable(TableDestination:=PSheet.Cells(3, 1), _
    TableName:="NB Summary")

'Insert Blank Pivot Table
Set PTable = PCache.CreatePivotTable _
    (TableDestination:=PSheet.Cells(1, 1), TableName:="NB Summary")
Dim Pvt As PivotTable
Set Pvt = Worksheets("PivotTable").PivotTables("NB Summary")

'Add fields to rows & values, re-name title of value
With Pvt
    .PivotFields("Policy Form").Orientation = xlColumnField
.PivotFields("Phone/Email").Orientation = xlRowField
    .AddDataField .PivotFields("Policy Number"), "Count of Policy Number", xlCount
End With

PSheet.Range("B5:B6").Copy
SSheet.Range("E6").PasteSpecial Paste:=xlPasteValues
PSheet.Range("C5:C6").Copy
SSheet.Range("G6").PasteSpecial Paste:=xlPasteValues

''''
'SE'
''''
With Pvt
    .ClearAllFilters
    .PivotFields("Revised Territory").PivotFilter.Add Type:=xlCaptionContains, Value1:="SE"
End With

PSheet.Range("B5:B6").Copy
SSheet.Range("E12").PasteSpecial Paste:=xlPasteValues
PSheet.Range("C5:C6").Copy
SSheet.Range("G12").PasteSpecial Paste:=xlPasteValues

'Delete PivotTable Sheet
Application.DisplayAlerts = False
Worksheets("PivotTable").Delete
Application.DisplayAlerts = True

End Sub

Answer 1

试试下面的代码，代码的cmets中有详细的解释。

修改后的代码

Option Explicit

Sub InsertPivotTable()

''''''''''''''''''
'''Pivot Set Up'''
''''''''''''''''''
'Declare Variables
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim SSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PFld As PivotField
Dim PItm As PivotItem
Dim PRange As Range
Dim LastRow As Long, LastCol As Long

' --- Check if there's already a sheet named "PivotTable" ---
On Error Resume Next
Set PSheet = ThisWorkbook.Sheets("PivotTable")
On Error GoTo 0
If PSheet Is Nothing Then ' there's no sheet named "PivotTable" >> create one
    Set PSheet = ThisWorkbook.Sheets.Add(Before:=ActiveSheet)
    PSheet.Name = "PivotTable"
End If

Application.DisplayAlerts = True

Set DSheet = Worksheets("PIF Data")
Set SSheet = Worksheets("Summary")

'Define Data Range
With DSheet
    LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    LastCol = 76 ' <-- you have 76 Colkumns of Data ??!
    Set PRange = .Cells(1, 1).Resize(LastRow, LastCol)
End With

'''''''''
'Summary'
'''''''''
' Set Pivot Cache object
Set PCache = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=PRange.Address(False, False, xlA1, xlExternal))

' create a new Pivot Table in "PivotTable" sheet, start from Cell A1
Set PTable = PSheet.PivotTables.Add(PivotCache:=PCache, TableDestination:=PSheet.Range("A1"), TableName:="NB Summary")

' Add fields to rows & values, re-name title of value
With PTable
    .PivotFields("Policy Form").Orientation = xlColumnField
    .PivotFields("Phone/Email").Orientation = xlRowField
    .AddDataField .PivotFields("Policy Number"), "Count of Policy Number", xlCount
End With

PSheet.Range("B5:B6").Copy
SSheet.Range("E6").PasteSpecial Paste:=xlPasteValues
PSheet.Range("C5:C6").Copy
SSheet.Range("G6").PasteSpecial Paste:=xlPasteValues

''''
'SE'
''''
' ===== Filter PivotField "Revised Territory" section according to "SE" =====
With PTable
    .ClearAllFilters

    ' set PivotField "Revised Territory"
    Set PFld = .PivotFields("Revised Territory")

    With PFld
        .Orientation = xlPageField
        .Position = 1

        ' loop through PivotField "Revised Territory" pivot-items
        For Each PItm In .PivotItems
            If PItm.Caption = "SE" Then
                PItm.Visible = True
            Else
                PItm.Visible = False
            End If
        Next PItm
    End With
End With

PSheet.Range("B5:B6").Copy
SSheet.Range("E12").PasteSpecial Paste:=xlPasteValues
PSheet.Range("C5:C6").Copy
SSheet.Range("G12").PasteSpecial Paste:=xlPasteValues

'Delete PivotTable Sheet
Application.DisplayAlerts = False
PSheet.Delete
Application.DisplayAlerts = True

End Sub