Odtwarzanie danych źródłowych z pamięci podręcznej tabeli przestawnej

Question

Próbuję wyodrębnić dane źródłowe z tabeli przestawnej, która korzysta z pamięci podręcznej tabeli przestawnej i umieścić ją w pustym arkuszu kalkulacyjnym. Próbowałem wykonać następujące czynności, ale zwraca błąd zdefiniowany przez aplikację lub zdefiniowany przez obiekt.

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

Documentation wskazuje PivotCache.Recordset jest typu ADO, więc to powinno działać. Mam włączone biblioteki ADO w referencjach.

Wszelkie sugestie, jak to osiągnąć?

Answer 1

Niestety, wydaje się, że nie ma sposobu bezpośredniego manipulowania plikiem PivotCache w programie Excel.

Znalazłem pracę. Poniższy kod wyodrębnia pamięć podręczną przestawną dla każdej tabeli przestawnej znajdującej się w skoroszycie, umieszcza ją w nowej tabeli przestawnej i tworzy tylko jedno pole przestawne (w celu zapewnienia, że ​​wszystkie wiersze z pamięci podręcznej przestawnej są uwzględnione w sumie), a następnie uruchamia się ShowDetail, który tworzy nowy arkusz zawierający wszystkie dane tabeli przestawnej.

Nadal chciałbym znaleźć sposób pracy bezpośrednio z PivotCache, ale to się załatwia.

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

przejść do okna Immediate i wpisz

? Thisworkbook.PivotCaches (1) .QueryType

Jeśli masz coś innego niż 7 (xlADORecordset), następnie własność rekordów nie ma zastosowania do tego typu PivotCache i zwróci ten błąd.

Jeśli pojawi się błąd w tym wierszu, wówczas PivotCache w ogóle nie jest oparty na danych zewnętrznych.

Jeśli dane źródło pochodzi z ThisWorkbook (tzn danych Excel), a następnie można użyć

? Thisworkbook.PivotCaches (1) .SourceData

Aby utworzyć obiekt dystansu oraz pętlę przez nią.

Jeśli QueryType jest 1 (xlODBCQuery), następnie SourceData będzie zawierać ciąg połączenia i CommandText za tworzenie i ADO rekordów, na przykład:

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

Musisz odniesienie ADO, ale ty mówiłeś już masz ten zestaw.

Answer 3

znalazłem się ten sam problem, potrzebując do skrobania programowo danych pochodzących z różnych wyróżnia buforowanych danych obrotu. Chociaż temat jest nieco stary, wciąż wygląda na to, że nie ma bezpośredniego dostępu do danych.

Poniżej znajduje się mój kod, który jest bardziej ogólnym uściśleniem już opublikowanego rozwiązania.

Główną różnicą jest usunięcie filtra z pól, ponieważ czasami pivot jest dostarczany z filtrami, a jeśli zadzwonisz .Showdetail nie przeoczy filtrowanych danych.

Używam go do skrobania z różnych formatów plików bez konieczności ich otwierania, jest to dla mnie całkiem dobre jak dotąd.

Mam nadzieję, że przyda się.

zgłosił spreadsheetguru.com na rutynowego czyszczenia filtra (choć nie pamiętam ile jest oryginalny i ile jest moja szczerze mówiąc)

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