2 einzelne Blätter in neuer Datei ohne Makros speichern
13.01.2025 20:23:17
{Boris}
ich habe eine umfangreiche Datei (mit vielen Blättern), aus der ich 2 einzelne Blätter (enthalten Pivottabellen - heißen Pivot_Member und Pivot_Color) extrahieren und ohne Makros in einer neuen xlsx ohne systemseitige Rückfragen speichern möchte (die Blätter enthalten jeweils Ereigniscodes Worksheet_Activate zum Aktualisieren der Pivottabellen und die neue Datei darf keine Makros enthalten).
Ich hab mir dazu folgenden (funktionierenden) Code zusammengeklöppelt - aber das sieht ein bisschen nach "brute force" aus. Passt das von der Vorgehensweise (nach schnellem Drüberschauen) so oder würdet ihr es grundsätzlich anders machen? Falls ja: Wie?
Option Explicit
Sub Pivottabellen_in_neuer_Mappe_speichern()
'speichert die beiden Pivottabellen OHNE Makros
Dim wbNeu As Workbook
Dim sFilename As String
Dim objWs As Object
Dim s As String
On Error GoTo ERR_HANDLER
s = Range("A4").Text & "_Pivottabellen.xlsx" 'Das ist der Vorschlag für den neuen Dateinamen
Application.EnableEvents = False
Application.DisplayAlerts = False
Set objWs = Sheets(Array("Pivot_Member", "Pivot_Color"))
objWs.Copy
Set wbNeu = ActiveWorkbook
' Speicherort wählen und Dateinamen definieren/vorschlagen
sFilename = Application.GetSaveAsFilename(s, "Excel-Arbeitsmappe (*.xlsx), *.xlsx")
' Arbeitsmappe speichern
If sFilename > "Falsch" Then
wbNeu.SaveAs Filename:=sFilename, FileFormat:=xlOpenXMLWorkbook
wbNeu.Close
MsgBox "Datei erfolgreich gespeichert.", vbInformation, "Erledigt"
Else
MsgBox "Speichern abgebrochen."
wbNeu.Close SaveChanges:=False
End If
ERR_HANDLER:
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
Danke vorab für Euren Input!
VG, Boris
Anzeige