winget
Goto Top

Pivottabelle als neue Datei (nicht als Pivot) speichern und Format übertragen, Blatt und Dateiname aus einer Zelle (nur einen Teil) übernehmen.

Hallo zusammen,
ich suchen nach einer VBA Lösung, die mir fogendes ermöglicht:

1. Pivottabelletabelle soll als eine neue Datei gespeichert werden, wobei das Format (Fett, Kursiv, Farbe etc) soll beibehalten werden.
2. Die Dateiname und Blattname soll aus z.B. Zelle A1 (aber nur die letzten 8 Zeichen) ausgelesen werden.

Vielen Dank im Voraus

BILD

Content-Key: 251180

Url: https://administrator.de/contentid/251180

Ausgedruckt am: 29.03.2024 um 15:03 Uhr

Mitglied: colinardo
colinardo 07.10.2014, aktualisiert am 08.10.2014 um 09:58:34 Uhr
Goto Top
Hallo winget,
das lässt sich machen, hier der Beispiel-Code. Anzupassen ist das Sheet (Zeile 4) auf dem die Pivottabelle liegt und der Name der Pivottabelle (Zeile 6). Der Code kopiert dann den Bereich der Pivotabelle in eine neue Arbeitsmappe (dabei wird nicht die Pivottabelle ansich kopiert sondern nur die Werte und Formate der Zellen in der Pivot, so wie du es wolltest), und speichert diese im selben Verzeichnis wie die aktuelle Mappe (das kannst du aber in Zeile 22 abändern)
Sub ExportPivotTable()
    Dim ws As Worksheet, newWB As Workbook, p As PivotTable, strNewName As String
    'Tabellenblatt definieren auf dem die Pivottabelle liegt  
    Set ws = Sheets(1)
    'Pivottabelle anhand Ihres Namens referenzieren  
    Set p = ws.PivotTables("PivotTable1")  
    'Gesamtbereich der Pivottabelle kopieren  
    p.TableRange2.Copy
    'Neue Arbeitsmappe erstellen  
    Set newWB = Workbooks.Add
    'Füge die Pivottabell als reine Daten mit Formatierung in die neue Mappe ein  
    With newWB.Sheets(1).Range("A1")  
        .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        .PasteSpecial Paste:=xlPasteFormats
        .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    'Name der neuen Arbeitsmappe aus Zelle A1 des Worksheets auslesen (letzte 8 Zeichen der Zelle)  
    strNewName = Right(ws.Range("A1").Value, 8)  
    'Name des Sheets setzen  
    newWB.Sheets(1).Name = strNewName
    'Neue Arbeitsmappe im selben Verzeichnis wie diese speichern  
    newWB.SaveAs ThisWorkbook.Path & "\" & strNewName & ".xlsx"  
    'neue Mappe schließen  
    newWB.Close True
End Sub
Weitere Kommentare findest du im Code

Grüße Uwe
Mitglied: winget
winget 08.10.2014 um 10:36:15 Uhr
Goto Top
Hi Uwe,
wie immer sind deine Lösungen Klasse.
Ich habe nur ein kleines Problem.
In der Zeile 1-2 befindet sich mein Kopfbereich (die Daten sind statisch).
Wie kann ich das lösen?

Dein Code habe ich entsprechend angepasst, so dass die Daten erst ab Zelle A3 eingefügt werden.

Schon mal vielen Dank
Gruß
Paul
Mitglied: colinardo
colinardo 08.10.2014 aktualisiert um 10:40:12 Uhr
Goto Top
Zitat von @winget:
In der Zeile 1-2 befindet sich mein Kopfbereich (die Daten sind statisch).
Wie kann ich das lösen?
erklär mal ... wo? in der Pivot oder woanders ?
Mitglied: winget
winget 08.10.2014 um 10:55:53 Uhr
Goto Top
Ja. In der Pivottabelle >in der Sheet(1)<

Zur Verdeutlichung:
A1:E2 (statische Daten) > Kopfbereich
A3:E97(Pivot Daten - dynamisch) ist aber durch ("PivotTable1") definiert bzw. referenziert.

Die Zeile 12 habe ich bereits in (A3) geändert.

Danke noch mal
Mitglied: colinardo
colinardo 08.10.2014 aktualisiert um 11:01:28 Uhr
Goto Top
Zitat von @winget:
Zur Verdeutlichung:
A1:E2 (statische Daten) > Kopfbereich
Ist das Der Kopfbereich bzw. der Page-Bereich der Pivot ? und was willst du damit jetzt, willst du den nicht übernehmen oder doch ??

p.TableRange2.Copy 
kopiert die Pivot inklusive Kopfdaten (wenn ein Pivot-Page-Filter aktiviert ist)
p.TableRange1.Copy 
und das nur die Tabellendaten der Pivot
Mitglied: winget
winget 08.10.2014 um 11:01:26 Uhr
Goto Top
Ich will mit übernehmen!
Das ist der Page-Bereich der Pivot!
Mitglied: colinardo
colinardo 08.10.2014 aktualisiert um 11:06:03 Uhr
Goto Top
Zitat von @winget:

Ich will mit übernehmen!
Das ist der Page-Bereich der Pivot!
der wird automatisch durch die Range Eigenschaft TableRange2 mit übernommen, wenn es tatsächlich der Pagebereich ist (geht hier einwandfrei, ansonsten mach mal ein Bild)
p.TableRange2.Copy
Mitglied: winget
winget 08.10.2014 aktualisiert um 12:04:29 Uhr
Goto Top
Hi Uwe,
ich konnte über die Seite nich hochlanden.
Ich habe das Bild bei dropbox hochgeladen. Siehe Original-Beitrag

ob mit p.TableRange2.Copy oder p.TableRange1.Copy wird immer der Bereich (Pivobereich) A3:E26 kopiert und in die neue Datei eingefügt.

Danke
Paul
Mitglied: colinardo
colinardo 08.10.2014 aktualisiert um 12:20:19 Uhr
Goto Top
ich hatte mit Pagebereich, den Kriterienbereich der Pivottabelle gemeint das ist was anderes als du vermutlich dachtest face-wink.....
egal du änderst Zeile 8 folgendermaßen ab:
ws.Range(p.TableRange2.Offset(-2, 0), p.TableRange2).Copy
und dein geändertes A3 kannst du wieder auf A1 ändern, bzw. dort wohin du die Tabelle im neuen Sheet platzieren willst.

Grüße Uwe
Mitglied: winget
winget 08.10.2014 um 12:27:48 Uhr
Goto Top
Kopieren funktioniert jetzt schon mal super.
Das Format für den "Kriterienbreich" wird aber nicht übertragen. face-smile

Aber das Funktioniert auch nicht, wenn man manuell die koplette Pivotabelle als Werte in einer anderen Tabelle überträgt und das das Format für die komplette Tabelle.
Für den Kriterienbereich muss man separat markieren und das Format übertragen.

Grüße
Paul
Mitglied: colinardo
colinardo 08.10.2014 aktualisiert um 12:47:10 Uhr
Goto Top
Zitat von @winget:

Kopieren funktioniert jetzt schon mal super.
Das Format für den "Kriterienbreich" wird aber nicht übertragen. face-smile
Die Formatierung musst du in der Pivottabelle nochmal wiederholen damit die Formate übertragen werden, nur selber eingefügte Formatierungen werden hierbei übertragen, die Pivot ist da leider besonders zu betrachten...wenn ich noch ein Workaround finde melde ich mich...
Mitglied: colinardo
colinardo 08.10.2014 aktualisiert um 13:17:21 Uhr
Goto Top
Als Workaround kannst du es nach deinem gepostetem Bild so machen (hier wird die Formatierung des Detailbereiches dann mit übertragen):
Sub ExportPivotTable()
    Dim ws As Worksheet, newWB As Workbook, p As PivotTable, strNewName As String
    'Tabellenblatt setzen auf dem die Pivottabelle liegt  
    Set ws = Sheets(1)
    'Pivottabelle anhand Ihres Namens refernzieren  
    Set p = ws.PivotTables("PivotTable1")  
    'Bereich der Pivottabelle kopieren  
    p.TableRange1.Copy
    'Neue Arbeitsmappe erstellen  
    Set newWB = Workbooks.Add
    'Füge die Pivottabelle als reine Daten mit Formatierung in die neue Mappe ein  
    With newWB.Sheets(1).Range("A3")  
        .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        .PasteSpecial Paste:=xlPasteFormats
        .PasteSpecial Paste:=xlPasteColumnWidths
    End With
    'Kopfzeilen übertragen  
    ws.Range("1:2").Copy newWB.Sheets(1).Range("A1")  
    
    'Name der neuen Arbeitsmappe aus Zelle A1 des Worksheets auslesen (letzte 8 Zeichen der Zelle)  
    strNewName = Right(ws.Range("A1").Value, 8)  
    'Name des Sheets setzen  
    newWB.Sheets(1).Name = strNewName
    'Neue Arbeitsmappe im selben Verzeichnis wie diese speichern  
    newWB.SaveAs ThisWorkbook.Path & "\" & strNewName & ".xlsx"  
    'neue Mappe schließen  
    newWB.Close True
End Sub
Mitglied: winget
winget 08.10.2014 um 14:37:49 Uhr
Goto Top
Das funktioniert Super... face-smile
Vielen Dank noch mal