VBA: Pivot : Pro Datensatz ein Sheet erstellen
09.12.2011 11:00:56
NoNet
Hallo steve,
jetzt bin ich wieder wach, gestern Nacht war mir das zu spät.
Hier ein VBA-Codebeispiel, wie man aus einer (einfachen) PIVOT-Tabelle des aktuellen Blattes die einzelnen Datenzeilen in ein jeweils entsprechend benamtes Blatt kopieren kann :
Sub AllePivotDetails_Separieren()
'PIVOT-Ergebnisse als separates Blatt separieren und Blatt benennen
'23.03./09.12.2011, NoNet - www.excelei.de
Dim rngZ As Range, strName As String
Dim pivAkt As PivotTable, wbAkt As Workbook
Dim lngLS As Long, lngPiv As Long
Set wbAkt = ActiveWorkbook
If ActiveSheet.PivotTables.Count > 0 Then
If MsgBox("Sollen jetzt aus der PIVOT-Tabelle jeweils einzelne Tabs erstellt werden ?" & _
_
vbLf & vbLf & "HINWEIS : Evtl. bestehende TABS werden zuvor gelöscht !!" & _
vbLf & vbLf & wbAkt.Path, vbYesNo + vbQuestion, "PIVOT-Tabelle sparieren") = vbYes _
Then
'Sheets("PivotTable").Select 'Blatt mit PIVOT-Tabelle evtl. zuvor aktivieren
Set pivAkt = ActiveSheet.PivotTables(1)
pivAkt.ColumnGrand = False 'Zeile "Gesamtergebnis" ausblenden
lngLS = pivAkt.DataBodyRange.Column
'Meldungen abschalten, um bestehendes Blatt ohne Rückfrage zu löschen :
Application.DisplayAlerts = False
For Each rngZ In Intersect(Columns(lngLS), pivAkt.DataBodyRange)
lngPiv = lngPiv + 1
rngZ.ShowDetail = True 'Detailzeilen auf neues separates Blatt kopieren
If rngZ.Offset(, -1) "" Then
strName = Left(rngZ.Offset(, -1), 31) 'Max. 31 Zeichen als _
Tabellenblattname
Else
strName = "Piv. " & lngPiv
End If
On Error Resume Next 'falls ungültiger Blattname
Sheets(strName).Delete 'Evtl. bereits bestehendes Blatt löschen
ActiveSheet.Name = strName 'Blatt gemäß PIVOT-Zeile benennen
ActiveSheet.Move after:=Sheets(Sheets.Count) 'Blatt ganz an das Ende _
verschieben
[A1].Select
Next
pivAkt.Parent.Activate 'Blatt der PIVOT-Tabelle wieder aktivieren
'Meldungen wieder einschalten, um bestehendes Blatt ohne Rückfrage zu löschen :
Application.DisplayAlerts = True
MsgBox "Fertig !"
End If
Else
MsgBox "Das aktuelle Blatt beinhaltet keine PIVOT-Tabelle !", vbOKOnly + vbCritical, _
"Trennung PIVOT-Tabelle nicht möglich !"
End If
End Sub
Falls es das Blatt mit dem entsprechenden Namen bereits gibt, wird dieses kompromisslos zuvor gelöscht.
Gruß, NoNet