尝试添加过滤器以使用VBA进行数据透视

sc1324 发表于 Dev

sc1324

我正在尝试在数据透视表上运行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

Shai Rado

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

修改后的代码

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

本文收集自互联网，转载请注明来源。

如有侵权，请联系 [email protected] 删除。