Tabellenblätter inkl. Pivot mit Makro kopieren
05.04.2019 08:47:43
Melissa
gerne möchte ich mehrere Tabellenblätter (inkl. Pivot / und Texte) mit einem Makro kopieren. Das Format soll entsprechend übernommen werden.
Für ein Tabellenblatt bekomme ich es mit diesem Code schon hin:
Sub ExportPivotTable()
Dim ws As Worksheet, newWB As Workbook, p As PivotTable, strNewName As String
'Tabellenblatt setzen auf dem die Pivottabelle liegt
Set ws = Tabelle12
'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("A12")
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
End With
'Kopfzeilen übertragen
ws.Range("1:8").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, 21)
'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
Wie kann ich dies auch für die weiteren Tabellenblätter umsetzen?
Danke & viele Grüße
Melissa
Anzeige