AW: Pivot-Tabelle Berichtsseiten
30.10.2014 12:05:44
fcs
Hallo Martin,
wenn man Pivot-Tabelle und eingbettetes Diagramm für jeden Filterwert eines Berichtsfeldes kopieren möchte, dann muss man jeweils das komplette Sheet/Tabellenblatt kopieren.
Namchfolgend ein entsprechendes Makro in dem du Blatt und Feldnamen noch anpassen mus.
Gruß
Franz
'Erstellt unter Excel 2010
Sub Pivots_mit_Diagramm_Berichtsfelder()
'Tabellenblatt mit Pivottabelle und Diagramm für jeden Filterwert kopieren _
und Filter setzen
Dim wksPivot As Worksheet, wksAktiv As Worksheet
Dim strBerichtsfeld As String
Dim pvTab As PivotTable, pvField As PivotField, pvItem As PivotItem
Dim intItem As Integer, arrItems() As String
'Tabellenblatt mit Original-Pivotbericht und -Diagramm
Set wksPivot = ActiveWorkbook.Worksheets("Auswertung") 'Name ggf. anpassen
Set pvTab = wksPivot.PivotTables(1)
strBerichtsfeld = "Kunde" 'Name des Berichtsfeldes - ggf. anpassen
Set pvField = pvTab.PageFields(strBerichtsfeld)
'Filter für Feld zurücksetzen und alle Filterwerte/Items in Array einlesen
pvField.ClearAllFilters
ReDim arrItems(1 To pvField.PivotItems.Count)
'Alle Pivotitems in Array einlesen
For Each pvItem In pvField.PivotItems
intItem = intItem + 1
ReDim Preserve arrItems(1 To intItem)
arrItems(intItem) = pvItem.Name
Next
'Auswertungsblatt mit Pivot/Diagramm für jeden Filterwert des Berichtsfeldes _
kopieren und Filterwert setzen
For intItem = 1 To UBound(arrItems)
Select Case arrItems(intItem)
Case "(All)", "(Alle)"
'do nothing
Case Else
wksPivot.Copy after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
Set wksAktiv = ActiveSheet
'Blattname anpassen
wksAktiv.Name = Left(Format(intItem, "00") & "-" & arrItems(intItem), 32)
Set pvTab = wksAktiv.PivotTables(1)
Set pvField = pvTab.PageFields(strBerichtsfeld)
pvField.CurrentPage = arrItems(intItem)
pvTab.RefreshTable 'evtl. nicht notwendig
End Select
If intItem = 3 Then Exit For 'Notausgang zum Testen - Zeile löschen wenn alles funktioniert
Next
End Sub