需要用于将数据透视表/数据透视表复制到新工作表上的代码

Question

所以我有一个数据表。在此数据表上，有一个按钮可使用DataSheet上的数据创建新的数据表和数据透视表。此按钮还在新的数据透视表工作表内创建另一个按钮，称为“创建数据透视图”（该数据表使用数据透视表数据创建数据透视图并将其放在新的工作表上）。这对于制作一个数据透视表和一个数据透视表非常完美，但是我需要能够使用相同的数据但使用不同的过滤器等来创建多个数据透视表/图表。

Private Sub PivotTableButton1_Click()


'Macro By ExcelChamps

'Declare Variables
Dim PSheet As Worksheet
Dim DSheet 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
Application.DisplayAlerts = False
Worksheets("PivotTable").Delete
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "PivotTable"
Application.DisplayAlerts = True
Set PSheet = Worksheets("PivotTable")
Set DSheet = Worksheets("DataTable")

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

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

'Insert Blank Pivot Table
Set PTable = PCache.CreatePivotTable _
(TableDestination:=PSheet.Cells(1, 1), TableName:="ParetoPivotTable")

'Insert Row Fields
With ActiveSheet.PivotTables("ParetoPivotTable").PivotFields("Pareto")
.Orientation = xlRowField
.Position = 1
End With

'Insert Column Fields


'Insert Data Field
With ActiveSheet.PivotTables("ParetoPivotTable").PivotFields("Pareto")
.Orientation = xlDataField
.Position = 1
.Function = xlCount
.Name = "Pareto"
End With

'Insert Filter
With ActiveSheet.PivotTables("ParetoPivotTable").PivotFields("model_code")
        .Orientation = xlPageField
        .Position = 1
    End With



'Format Pivot Table

ActiveSheet.PivotTables("ParetoPivotTable").PivotFields("Pareto").AutoSort _
        xlDescending, "Count of Pareto"


    Dim objObject As Object
    Dim strCode As String
        Set objObject = ActiveSheet.Buttons.Add(611.25, 63, 138, 39)
        objObject.Name = "PivotChartButton"
        objObject.Caption = "Create PivotChart"
        objObject.OnAction = "PivotChartButton_Click"


End Sub

Sub PivotChartButton_Click()

On Error Resume Next
Application.DisplayAlerts = False
Worksheets("PivotChart").Delete
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "PivotChart"
Application.DisplayAlerts = True


    Dim wksPivot As Worksheet
    Dim wksDest As Worksheet
    Dim oChart As Chart
    Dim oPT As PivotTable
    Dim rDest As Range

    Set wksPivot = Worksheets("PivotTable") 'change the sheet name accordingly
    Set wksDest = Worksheets("PivotChart") 'change the sheet name accordingly

    Set oPT = wksPivot.PivotTables("ParetoPivotTable")

    Set rDest = wksDest.Range("E2:X35")

    With rDest
        Set oChart = wksDest.ChartObjects.Add(Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height).Chart
    End With

    With oChart
        .ChartType = xlColumnClustered
        .SetSourceData oPT.TableRange1
    End With

    wksDest.Activate

End Sub

仅复制数据透视表工作即可，但是复制的工作表上的按钮会覆盖原始工作表上的按钮...