Recreate Source Data from PivotTable Cache

Question

I am trying to extract the source data from a PivotTable that uses a PivotTable cache and place it into a blank spreadsheet. I tried the following but it returns an application-defined or object defined error.

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

Documentation indicates that PivotCache.Recordset is an ADO type, so this ought to work. I do have the ADO library enabled in references.

Any suggestions on how to achieve this?

Answer 1

Unfortunately, there appears to be no way to directly manipulate PivotCache in Excel.

I did find a work around. The following code extracts the the pivot cache for every pivot table found in a workbook, puts it into a new pivot table and creates only one pivot field (to ensure that all rows from the pivot cache are incorporated in the total), and then fires ShowDetail, which creates a new sheet with all of the pivot table's data in.

I would still like to find a way to work directly with PivotCache but this gets the job done.

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