从数据透视表缓存中重新创建源数据

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