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

我试图从使用数据透视表缓存的数据透视表中提取源数据，并将其放入空白电子表格中。我尝试了以下操作，但它返回应用程序定义或对象定义的错误

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

指示PivotCache.Recordset是ADO类型，因此应该可以工作。我确实在引用中启用了ADO库

---

有关如何实现此目标的任何建议？

转到即时窗口并键入

？此工作簿。数据透视缓存（1）。查询类型

如果您得到的不是7（xlADORecordset），则Recordset属性不适用于此类型的数据透视缓存，并将返回该错误

如果该行出现错误，则数据透视缓存根本不基于外部数据

如果源数据来自此工作簿（即Excel数据），则可以使用

？此工作簿。数据透视缓存（1）。源数据

创建范围对象并在其中循环

如果查询类型为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引用，但您说已经有了该集合。

不幸的是，似乎无法在Excel中直接操作数据透视缓存

我确实找到了一份工作。以下代码为工作簿中找到的每个数据透视表提取数据透视缓存，将其放入一个新的数据透视表中，并仅创建一个数据透视字段（以确保数据透视缓存中的所有行都包含在总数中），然后激发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

Public Sub-ExtractPivotTableData（）
作为工作簿的Dim objActiveBook
将objSheet设置为工作表
Dim objPivotTable作为数据透视表
将objTempSheet设置为工作表
作为数据透视表的Dim OBJTEMPIVOT
如果TypeName（Application.Selection）“Range”，则
嘟嘟声
出口接头
ElseIf WorksheetFunction.CountA（单元格）=0，然后
嘟嘟声
出口接头
其他的
设置objActiveBook=ActiveWorkbook
如果结束
应用
.ScreenUpdate=False
.DisplayAlerts=False
以
对于objActiveBook.Sheets中的每个objSheet
对于objSheet.PivotTables中的每个objPivotTable
使用objActiveBook.Sheets.Add（，objSheet）
使用objPivotTable.PivotCache.CreatePivotTable（.Range（“A1”））
.AddDataField.PivotFields（1）
以
.Range（“B2”）.ShowDetail=True
objActiveBook.Sheets（.Index-1）.Name=“工作表的源数据”&objSheet.Index
objActiveBook.Sheets（.Index-1）.Tab.Color=255
.删除
以
下一个
下一个
应用
.ScreenUpdate=True
.DisplayAlerts=True
以
端接头

我发现自己也有同样的问题，需要以编程方式刮取缓存的Pivot数据中不同的数据。 虽然这个话题有点老，但看起来仍然没有直接的方法来访问数据

下面您可以找到我的代码，它是对已经发布的解决方案的更一般化的改进

主要区别在于从字段中删除了过滤器，因为有时pivot会打开过滤器，如果调用.Showdetail，它将丢失过滤后的数据

我用它从不同的文件格式中刮取，而不必打开它们，到目前为止，它为我提供了很好的服务

希望它有用

spreadsheetguru.com在过滤器清洁程序上的功劳（尽管我不记得有多少是原创的，老实说，有多少是我的）

---

调试。打印此工作簿。数据透视缓存（1）。QueryType引发错误。数据透视缓存（1）。SourceData返回存储源数据的外部工作簿的路径。数据透视表是使用已删除的外部工作簿（数据透视表（1）中的数据创建的。SaveData为True）。我想从pivot缓存中重新创建原始源数据。当您说“从SourceData创建一个range对象并在其中循环”时，我猜您的意思是使用range（SourceData）引用SourceData指定的range对象，但这对我来说不可用。感谢您的帮助。如果双击透视表中的单元格，或右键单击并选择“显示详细信息”，Excel将该计算的源数据导出到同一工作簿中的新电子表格中。但是，一次只能执行一个单元格。我需要对整个数据透视表执行此操作，然后自动执行此过程。

此工作簿的运行时值是多少。数据透视缓存（1）。记录集

？它是一个记录计数为49的记录集，但如果我尝试执行以下操作，我也会得到应用程序定义或对象定义的错误：Dim objRecordset As ADODB.Recordset objRecordset=ThisWorkbook.PivotCaches（1）.Recordset将ThisWorkbook.PivotCaches（1）.记录集放入监视窗口，以查看其确切类型。这应该会有所帮助。在运行时，变量类型为Integer/Variant。当然，objRecordset是类型记录集。应用程序运行此工作簿后，数据透视缓存（1）。记录集将在监视窗口中显示应用程序定义或对象定义的错误。这让我相信，也许我忘记了一个参考资料。也许是数据透视缓存特有的东西？谢谢你的帮助。这是一个很好的解决方法，谢谢你发布它。我刚刚在Excel 2010中尝试了这一点，但由于任何原因，.ShowDetail行出现了一个错误。但是，我可以在这段代码生成的单单元格透视表上手动执行ShowDetails（通过UI上下文菜单），并以这种方式创建一个新的工作表。至少在Excel 2010下，行：“.Range（“B2”）.ShowDetail=True”实际上应该是：“.Range（“A2”）.ShowDetail=True”（A2而不是B2）

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