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

请尝试下面的代码，代码注释中的详细说明。

修改后的代码

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

尝试使用vba

1 个答案: