AW: Pivot Cache-Daten auslesen
24.08.2011 01:48:42
fcs
Hallo Michael,
wenn die Originaldatenquelle nicht mehr verfügbar ist, dann kannst du mit folgendem Makro die im Pivot-Cache vorhandenen Daten in eine Tabelle einlesen.
Getestet hab ich mit einer relativ kleinen Tabelle. Die Quelle des Pivotberichts war ursprünglich eine Exceltabelle.
Gruß
Franz
Sub getDatafromPivotCache()
Call PivotCacheDaten(pvCache:=ActiveWorkbook.Worksheets("Tabelle2").PivotTables(1).PivotCache) _
End Sub
Sub PivotCacheDaten(pvCache As PivotCache, Optional wksData As Worksheet)
Dim pvTab As PivotTable, pvField As PivotField
Dim sName As String
Dim ZeileCopy As Long, AnzZeilen As Long, SpErgebnis As Long, Zeile As Long, Spalte As Long
Application.ScreenUpdating = False
'Zieltabelle anlegen, wenn kein Ziel als Parameter angegeben wurde
If wksData Is Nothing Then
Worksheets.Add after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
Set wksData = ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
End If
Set pvTab = pvCache.CreatePivotTable(Tabledestination:=wksData.Range("A1"))
With pvTab
'Alle Spaltentitel als Reihenfelder
For Each pvField In .PivotFields
If Not pvField.IsCalculated Then .AddFields RowFields:=pvField.Name, addtotable:=True
Next
'Alle Reihenfelder ohne Zwischenergebnisse anzeigen
For Each pvField In .RowFields
pvField.Subtotals = Array(False, False, False, False, False, False, _
False, False, False, False, False, False)
Next
.ColumnGrand = False
.RowGrand = False
sName = .RowFields(.RowFields.Count).Name
.AddDataField .PivotFields(sName), Caption:=sName & "Test", Function:=xlCount
'nächste Zeile erforderlich da das Reihenfeld in den Datenbereich verschoben wurde
.AddFields RowFields:=sName, addtotable:=True
End With
wksData.Activate
With pvTab
'Werte im Pivotbericht kopieren und unterhalb einfügen
AnzZeilen = .TableRange1.Rows.Count
SpErgebnis = .TableRange1.Columns.Count
.TableRange1.EntireRow.Copy
wksData.Cells(AnzZeilen + 1, 1).PasteSpecial Paste:=xlPasteValues
'Zeilen des Pivot berichts löschen
.TableRange1.EntireRow.Delete
End With
With wksData
'Zeile mit Datenbereichsname löschen
.Rows(1).Delete
'Alle leeren Zellen mit Daten aus Zeile oberhalb auffüllen
For Zeile = 3 To AnzZeilen - 1
For Spalte = 1 To SpErgebnis - 1
If IsEmpty(.Cells(Zeile, Spalte)) Then .Cells(Zeile, Spalte) = .Cells(Zeile - 1, Spalte) _
If .Cells(Zeile, Spalte) = "(Leer)" Then .Cells(Zeile, Spalte).ClearContents
Next
Next
'Alle Zeilen mit Anzahl > 1 entsprechend oft kopieren
ZeileCopy = AnzZeilen - 1
For Zeile = 2 To AnzZeilen - 1
AnzZeilen = .Cells(Zeile, SpErgebnis)
If AnzZeilen > 1 Then
.Cells(Zeile, SpErgebnis) = 1
Do Until AnzZeilen = 1
ZeileCopy = ZeileCopy + 1
.Rows(Zeile).Copy Destination:=.Cells(ZeileCopy, 1)
AnzZeilen = AnzZeilen - 1
Loop
End If
Next
'Ergebnisspalte löschen
.Columns(SpErgebnis).Delete
.Columns.AutoFit
End With
Application.ScreenUpdating = True
Range("A2").Select
ActiveWindow.FreezePanes = True
End Sub