同一数据源在同一个工作表类创建多张数据透视表

ranger丶亦

最近迷上了用代码创建数据透视表，写了些代码，不是那么简洁，抛砖引玉
Sub 创建数据透视表()
Dim PTCache As PivotCache
Dim PT As PivotTable, PT2 As PivotTable
Dim iR As Integer, iC As Integer
Dim strSourceData

iR = Sheets("数据源").Cells(Rows.Count, 1).End(xlUp).Row
iC = Sheets("数据源").Cells(1, Columns.Count).End(xlToLeft).Column


strSourceData = "数据源!R1C1:R" & iR & "C" & iC
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Sheets("对比").Delete
Sheets.Add.Name = "对比"

Set PTCache = ActiveWorkbook.PivotCaches.Create( _
            SourceType:=xlDatabase, _
            SourceData:=strSourceData)
Set PT = ActiveSheet.PivotTables.Add( _
            PivotCache:=PTCache, _
            tabledestination:=Range("a1"), _
            TableName:="PivotTable1")

With PT
       .PivotFields("名称类别").Orientation = xlRowField
       .PivotFields("原类别").Orientation = xlRowField
       .PivotFields("新类别").Orientation = xlRowField
End With

With PT.PivotFields("结算金额")
       .Orientation = xlDataField
       .Function = xlSum
End With

With ActiveSheet.PivotTables("Pivottable1")
        .RowAxisLayout xlTabularRow
        .MergeLabels = True
        .Borders.LineStyle = xlContinuous
        '.PivotFields("原类别").Subtotals = Array(False, False _
             , False, False, False, False, False, False, False, False, False, False)
End With

With ActiveSheet.PivotTables("PivotTable1").PivotFields("原类别")
        .PivotItems("电线").Visible = False
End With

Set PT2 = ActiveSheet.PivotTables.Add( _
        PivotCache:=PTCache, _
        tabledestination:=Range("g1"), _
        TableName:="PivotTable2")

With PT2
       .PivotFields("名称类别").Orientation = xlRowField
       .PivotFields("新类别").Orientation = xlRowField
       .PivotFields("原类别").Orientation = xlRowField
End With

With PT2.PivotFields("结算金额")
        .Orientation = xlDataField
        .Function = xlSum
End With


With ActiveSheet.PivotTables("PivotTable2")
        .RowAxisLayout xlTabularRow
        .MergeLabels = True
        .Borders.LineStyle = xlContinuous
        '.PivotFields("新类别").Subtotals = Array(False, False _
             , False, False, False, False, False, False, False, False, False, False)
End With

With ActiveSheet.PivotTables("PivotTable2").PivotFields("新类别")
        .PivotItems("电线").Visible = False
End With


Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

苏阳湖wzy

建议楼主上传附件！