Recreate Source Data from PivotTable Cache

Question

Estoy tratando de extraer los datos de origen de una tabla dinámica que usa un caché de tabla dinámica y colocarlo en una hoja de cálculo en blanco. Intenté lo siguiente pero devuelve un error definido por la aplicación o un error definido por el objeto.

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

Documentation indica que PivotCache.Recordset es un tipo de ADO, por lo que este debe trabajar. Tengo la biblioteca ADO habilitada en las referencias.

¿Alguna sugerencia sobre cómo lograr esto?

Answer 1

Desafortunadamente, parece que no hay forma de manipular directamente PivotCache en Excel.

Encontré un trabajo alrededor. El siguiente código extrae la memoria caché dinámica para cada tabla dinámica encontrada en un libro, la coloca en una nueva tabla dinámica y crea solo un campo pivote (para asegurar que todas las filas de la memoria caché dinámica estén incorporadas en el total), y luego dispara ShowDetail, que crea una nueva hoja con todos los datos de la tabla dinámica.

Todavía me gustaría encontrar una forma de trabajar directamente con PivotCache, pero esto hace el trabajo.

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

Ir a la ventana Inmediato y escriba

? Thisworkbook.PivotCaches (1) .QueryType

Si obtiene algo más que 7 (xlADORecordset), entonces la propiedad de registros no se aplica a este tipo de PivotCache y devolverá ese error.

Si obtiene un error en esa línea, entonces su PivotCache no se basa en datos externos en absoluto.

Si los datos de origen proviene de ThisWorkbook (es decir, datos de Excel), entonces se puede utilizar

? Thisworkbook.PivotCaches (1) .SourceData

Para crear un objeto de rango y el bucle a través de él.

Si su querytype es 1 (xlODBCQuery), entonces SourceData contendrá la cadena de conexión y CommandText para crear y registros ADO, así:

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

Es necesario la referencia ADO, pero dijo que ya tengo ese conjunto.

Answer 3

Me encontré teniendo el mismo problema, la necesidad de eliminar datos programáticamente procedentes de Excel diferentes con datos Pivot en caché. Aunque el tema es un poco antiguo, todavía parece que no hay una forma directa de acceder a los datos.

A continuación puede encontrar mi código, que es un refinamiento más generalizado de la solución ya publicada.

La principal diferencia es la eliminación del filtro de los campos, ya que a veces el pivote viene con filtros activados, y si llama a .Showdetail perderá los datos filtrados.

Lo uso para raspar desde diferentes formatos de archivo sin tener que abrirlos, me está sirviendo bastante bien hasta ahora.

Espero que sea útil.

crédito a spreadsheetguru.com en la rutina de limpieza del filtro (aunque no me acuerdo cuánto es original y cuánto es mío para ser honesto)

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