從單個數據源創建多個數據透視表

Question

我試圖在新工作表上創建數據透視表。此外，我想創建另一個調用，以使用第一個數據表中的相同數據創建另一個不同的數據透視表。

以下宏有問題。我認爲這是一個小錯誤，但無法弄清楚。

Sub Macro2() 

    Dim FinalRow   As Long 
    Dim DataSheet   As String 
    Dim PvtCache   As PivotCache 
    Dim PvtTbl    As PivotTable 
    Dim DataRng    As Range 
    Dim TableDest   As Range 
    Dim ws     As Worksheet 

    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row 
    DataSheet = ActiveSheet.Name 

    'set data range for Pivot Table -- ' conversion of R1C1:R & FinalRow & C15 
    Set DataRng = Sheets(DataSheet).Range(Cells(1, 1), Cells(FinalRow, 15)) 

    Set ws = Worksheets.Add 
    ws.Name = "Travel Payment Data by Employee" 

    'set range for Pivot table placement -- Conversion of R1C1 
    Set TableDest = Sheets("Travel Payment Data by Employee").Cells(1, 1) 

    Set PvtCache = ActiveWorkbook.PivotCaches.Create(xlDatabase, DataRng, xlPivotTableVersion15) 

    'check if "PivotTable4" Pivot Table already created (in past runs of this Macro) 
    Set PvtTbl = ActiveWorkbook.Sheets("Travel Payment Data by Employee").PivotTables("PivotTable4") 

    With PvtTbl.PivotFields("Security Org") 
     .Orientation = xlRowField 
     .Position = 1 
    End With 
    With PvtTbl.PivotFields("Fiscal Month") 
     .Orientation = xlRowField 
     .Position = 2 
    End With 
    With PvtTbl.PivotFields("Budget Org") 
     .Orientation = xlRowField 
     .Position = 3 
    End With 
    With PvtTbl.PivotFields("Vendor Name") 
     .Orientation = xlRowField 
     .Position = 4 
    End With 
    With PvtTbl.PivotFields("Fiscal Year") 
     .Orientation = xlRowField 
     .Position = 5 
    End With 
    With PvtTbl.PivotFields("Fiscal Year") 
     .Orientation = xlColumnField 
     .Position = 1 
    End With 
    PvtTbl.AddDataField ActiveSheet.PivotTables(_ 
     "PivotTable2").PivotFields("Dollar Amount"), "Sum of Dollar Amount", xlSum 

End Sub 

Answer 1

考慮一個子程序調用一個函數如下調整，並傳遞新的相同的數據透視表新的工作表的名稱。如果您不打算使用相同的支點，請用條形碼名稱或功能副本有條件地調整它們。從你的代碼，主要變化如下：

1. 活動工作表：刪除了需要尋找ActiveSheet.Name添加更多的工作表將改變積極的牀單。只需硬編碼或作爲參數傳遞數據源。
2. 對象檢查：您需要檢查工作表是否存在並且數據透視表是否存在。對於這些，您需要遍歷當前所有這些對象，並有條件地設置工作表，數據透視表對象（請參見For...Next循環和If ... Is Nothing檢查）。
3. 對於PivotField，由於美元數量爲將存在於數據透視表數據源中，但不一定顯示，遍歷所有數據可能不會像上面那樣工作。所以有條件地添加只有在不出錯的情況下才能看到On Resume Next句柄。

VBA

Option Explicit 

Public Sub RunPivots() 
    Call BuildPivot("Travel Payment Data by Employee") 
    Call BuildPivot("Other Worksheet") 
    Call BuildPivot("Still More Worksheet") 
End Sub 

Function BuildPivot(paramSheet As String) 
On Error GoTo ErrHandle 
    Dim FinalRow   As Long 
    Dim DataSheet   As String 
    Dim PvtCache   As PivotCache 
    Dim PvtTbl    As PivotTable 
    Dim PvtFld    As PivotField 
    Dim DataRng    As Range 
    Dim TableDest   As Range 
    Dim ws     As Worksheet 

    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row 

    DataSheet = "DataSourceWorksheet"  
    ' set data range for Pivot Table 
    Set DataRng = Sheets(DataSheet).Range(Cells(1, 1), Cells(FinalRow, 15)) 

    ' check if worksheet exists 
    Dim currws As Worksheet 
    For Each currws In ActiveWorkbook.Worksheets 
     If currws.Name = paramSheet Then 
      Set ws = Worksheets(paramSheet) 
      Exit For 
     End If 
    Next currws 

    ' create new worksheet if does not exist 
    If ws Is Nothing Then 
     Set ws = Worksheets.Add 
     ws.Name = paramSheet 
    End If 

    ' set range for Pivot table placement 
    Set TableDest = Sheets(paramSheet).Cells(1, 1) 

    ' create pivot cache 
    Set PvtCache = ActiveWorkbook.PivotCaches.Create(_ 
       SourceType:=xlDatabase, _ 
       SourceData:=DataRng, _ 
       Version:=xlPivotTableVersion15) 

    'check if "PivotTable4" Pivot Table exists    
    Dim currpvt As PivotTable 
    For Each currpvt In ws.PivotTables 
     If currpvt.Name = "PivotTable4" Then 
      Set PvtTbl = ws.PivotTables("PivotTable4") 
      Exit For 
     End If 
    Next currpvt 

    ' create new pivot table if does not exist 
    If PvtTbl Is Nothing Then 
     Set PvtTbl = PvtCache.CreatePivotTable(_ 
      TableDestination:=TableDest, _ 
      TableName:="PivotTable4") 
    End If 

    With PvtTbl.PivotFields("Security Org") 
     .Orientation = xlRowField 
     .Position = 1 
    End With 
    With PvtTbl.PivotFields("Fiscal Month") 
     .Orientation = xlRowField 
     .Position = 2 
    End With 
    With PvtTbl.PivotFields("Budget Org") 
     .Orientation = xlRowField 
     .Position = 3 
    End With 
    With PvtTbl.PivotFields("Vendor Name") 
     .Orientation = xlRowField 
     .Position = 4 
    End With 
    With PvtTbl.PivotFields("Fiscal Year") 
     .Orientation = xlRowField 
     .Position = 5 
    End With 
    With PvtTbl.PivotFields("Fiscal Year") 
     .Orientation = xlColumnField 
     .Position = 1 
    End With 

    ' Add data field if does not exist 
    On Error Resume Next 
    PvtTbl.AddDataField PvtTbl.PivotFields("Dollar Amount"), "Sum of Dollar Amount", xlSum 

    Exit Function 

ErrHandle: 
    MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR" 
    Exit Function 
End Function