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

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 251180

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

Ausgedruckt am: 22.11.2024 um 21:11 Uhr

13 Kommentare

Neuester Kommentar

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

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

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 ?

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

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

Ich will mit übernehmen!
Das ist der Page-Bereich der Pivot!

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

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

ich hatte mit Pagebereich, den Kriterienbereich der Pivottabelle gemeint das ist was anderes als du vermutlich dachtest

.....
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

Kopieren funktioniert jetzt schon mal super.
Das Format für den "Kriterienbreich" wird aber nicht übertragen.

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

Zitat von @winget:

Kopieren funktioniert jetzt schon mal super.
Das Format für den "Kriterienbreich" wird aber nicht übertragen.

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...

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