從數據透視表緩存中重新創建源數據

Question

我想從使用數據透視表緩存的數據透視表中提取源數據並將其放入空白電子表格中。我嘗試了以下，但它返回一個應用程序定義或對象定義的錯誤。

ThisWorkbook.Sheets.Add.Cells(1,1).CopyFromRecordset ThisWorkbook.PivotCaches(1).Recordset 

Documentation指示PivotCache.Recordset是一個ADO類型，所以這應該工作。我確實在引用中啓用了ADO庫。

有關如何實現此目的的任何建議？

Answer 1

不幸的是，似乎沒有辦法在Excel中直接操作PivotCache。

我找到了解決辦法。以下代碼爲工作簿中的每個數據透視表提取數據透視表緩存，將其放入新的數據透視表並僅創建一個透視表字段（以確保來自透視緩存的所有行都包含在總數中），然後觸發ShowDetail，創建與所有數據透視表的數據的新表。

我還是想找到一種方式直接與PivotCache工作，但這個能夠完成任務。

Public Sub ExtractPivotTableData() 

    Dim objActiveBook As Workbook 
    Dim objSheet As Worksheet 
    Dim objPivotTable As PivotTable 
    Dim objTempSheet As Worksheet 
    Dim objTempPivot As PivotTable 

    If TypeName(Application.Selection) <> "Range" Then 
     Beep 
     Exit Sub 
    ElseIf WorksheetFunction.CountA(Cells) = 0 Then 
     Beep 
     Exit Sub 
    Else 
     Set objActiveBook = ActiveWorkbook 
    End If 

    With Application 
     .ScreenUpdating = False 
     .DisplayAlerts = False 
    End With 

    For Each objSheet In objActiveBook.Sheets 
     For Each objPivotTable In objSheet.PivotTables 
      With objActiveBook.Sheets.Add(, objSheet) 
       With objPivotTable.PivotCache.CreatePivotTable(.Range("A1")) 
        .AddDataField .PivotFields(1) 
       End With 
       .Range("B2").ShowDetail = True 
       objActiveBook.Sheets(.Index - 1).Name = "SOURCE DATA FOR SHEET " & objSheet.Index 
       objActiveBook.Sheets(.Index - 1).Tab.Color = 255 
       .Delete 
      End With 
     Next 
    Next 

    With Application 
     .ScreenUpdating = True 
     .DisplayAlerts = True 
    End With 

End Sub 

Answer 2

轉到立即窗口並輸入

？thisworkbook.PivotCaches（1）.QueryType

如果你得到比7（xlADORecordset）其他東西，那麼Recordset屬性並不適用於這種類型的PivotCache並將返回該錯誤。

如果你在該行的錯誤，那麼你的PivotCache不是基於外部數據的。

如果源數據來自的ThisWorkbook（即Excel中的數據），那麼你可以使用

？thisworkbook.PivotCaches（1）.SourceData

通過它創建一個範圍對象和循環。

如果你的查詢類型爲1（xlODBCQuery），然後SourceData將包含連接字符串和CommandText中爲你創造和ADO記錄集，這樣的：

Sub DumpODBCPivotCache() 

    Dim pc As PivotCache 
    Dim cn As ADODB.Connection 
    Dim rs As ADODB.Recordset 

    Set pc = ThisWorkbook.PivotCaches(1) 
    Set cn = New ADODB.Connection 
    cn.Open pc.SourceData(1) 
    Set rs = cn.Execute(pc.SourceData(2)) 

    Sheet2.Range("a1").CopyFromRecordset rs 

    rs.Close 
    cn.Close 

    Set rs = Nothing 
    Set cn = Nothing 

End Sub

您需要的ADO參考，但你說你已經有了這一套。

Answer 3

我發現自己也遇到了同樣的問題，需要以編程方式擦除與緩存的Pivot數據不同的數據。 儘管主題有點舊，但仍然沒有直接訪問數據的方式。

您可以在下面找到我的代碼，這是對已發佈解決方案的更廣泛的改進。

主要區別在於篩選器從字段中刪除，因爲有時樞軸附帶了篩選器，並且如果您調用.Showdetail它將忽略過濾的數據。

我用它從不同的文件格式湊，而無需打開它們，這是我的服務很好迄今。

希望它是有用的。

感謝spreadsheetguru.com在過濾器清洗程序（雖然我不記得有多少是原創，是多麼雷說實話）

Option Explicit 

     Sub ExtractPivotData(wbFullName As String, Optional wbSheetName As_ 
String, Optional wbPivotName As String, Optional sOutputName As String, _ 
Optional sSheetOutputName As String) 

    ' This routine extracts full data from an Excel workbook and saves it to an .xls file. 

    Dim iPivotSheetCount As Integer 

Dim wbPIVOT As Workbook, wbNEW As Workbook, wsPIVOT As Worksheet 
Dim wsh As Worksheet, piv As PivotTable, pf As PivotField 
Dim sSaveTo As String 

Application.DisplayAlerts = False 
calcOFF 

Set wbPIVOT = Workbooks.Open(wbFullName) 

    ' loop through sheets 
    For Each wsh In wbPIVOT.Worksheets 
     ' if it is the sheet we want, OR if no sheet specified (in which case loop through all) 
     If (wsh.name = wbSheetName) Or (wbSheetName = "") Then 
      For Each piv In wsh.PivotTables 

      ' remove all filters and fields 
      PivotFieldHandle piv, True, True 

      ' make sure there's at least one (numeric) data field 
      For Each pf In piv.PivotFields 
       If pf.DataType = xlNumber Then 
        piv.AddDataField pf 
        Exit For 
       End If 
      Next pf 

      ' make sure grand totals are in 
      piv.ColumnGrand = True 
      piv.RowGrand = True 

      ' get da data 
      piv.DataBodyRange.Cells(piv.DataBodyRange.Cells.count).ShowDetail = True 

      ' rename data sheet 
      If sSheetOutputName = "" Then sSheetOutputName = "datadump" 
      wbPIVOT.Sheets(wsh.Index - 1).name = sSheetOutputName 

      ' move it to new sheet 
      Set wbNEW = Workbooks.Add 
      wbPIVOT.Sheets(sSheetOutputName).Move Before:=wbNEW.Sheets(1) 

      ' clean new file 
      wbNEW.Sheets("Sheet1").Delete 
      wbNEW.Sheets("Sheet2").Delete 
      wbNEW.Sheets("Sheet3").Delete 

      ' save it 
      If sOutputName = "" Then sOutputName = wbFullName 
      sSaveTo = PathWithSlash(wbPIVOT.path) & FilenameNoExtension(sOutputName) & "_data_" & piv.name & ".xls" 
      wbNEW.SaveAs sSaveTo 
      wbNEW.Close 
      Set wbNEW = Nothing 

      Next piv 
     End If 
    Next wsh 

wbPIVOT.Close False 
Set wbPIVOT = Nothing 

calcON 
Application.DisplayAlerts = True 

End Sub 


Sub PivotFieldHandle(pTable As PivotTable, Optional filterClear As Boolean, Optional fieldRemove As Boolean, Optional field As String) 
'PURPOSE: How to clear the Report Filter field 
'SOURCE: www.TheSpreadsheetGuru.com 

Dim pf As PivotField 

Select Case field 

    Case "" 
    ' no field specified - clear all! 

     For Each pf In pTable.PivotFields 
      Debug.Print pf.name 
      If fieldRemove Then pf.Orientation = xlHidden 
      If filterClear Then pf.ClearAllFilters 
     Next pf 


    Case Else 
    'Option 1: Clear Out Any Previous Filtering 
    Set pf = pTable.PivotFields(field) 
    pf.ClearAllFilters 

    ' Option 2: Show All (remove filtering) 
    ' pf.CurrentPage = "(All)" 
End Select 

End Sub