Einzelnes Blatt in neuer Mappe speichern

06/02/2010 - 10:47 von Detlef Rehn | Report spam
Hallo Newsgroup,

mit folgenden Code kann ich eine Mappe neu abspeichern und dabei den Namen
des aktiven Tabellenblatts und das Tagesdatum in den neuen Dateinamen
einfügen. Das ist so gewünscht. Allerdings möchte ich, dass allein dieses
Tabellenblatt gespeichert wird, nicht aber alle anderen Blàtter aus der
ursprünglichen Mappe. Wie muss ich den Code abàndern?

Sub SpeicherMirsAlsNeueMappe()
Dim wksA As Worksheet
Dim wbkNeu As Workbook
Dim vntPathAndFile As Variant

Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")

Set wksA = ActiveSheet
vntPathAndFile = Application.GetSaveAsFilename( _
InitialFileName:= _
fs.GetBaseName(ActiveWorkbook.Name) & " - " & _
wksA.Name & " -" & _
Format(Now, " yyyy-mm-dd") & ".xls", _
FileFilter:="Excel Files(*.xls), *.xls", _
Title:="Speichern als")

If Not vntPathAndFile = False Then
Set wbkNeu = ActiveWorkbook
wbkNeu.SaveCopyAs vntPathAndFile
wbkNeu.Close
End If
End Sub


Gruß, Detlef
 

Lesen sie die antworten

#1 Andreas Killer
07/02/2010 - 09:22 | Warnen spam
Detlef Rehn schrieb:

mit folgenden Code kann ich eine Mappe neu abspeichern und dabei den Namen
des aktiven Tabellenblatts und das Tagesdatum in den neuen Dateinamen
einfügen. Das ist so gewünscht. Allerdings möchte ich, dass allein dieses
Tabellenblatt gespeichert wird, nicht aber alle anderen Blàtter aus der
ursprünglichen Mappe. Wie muss ich den Code abàndern?


Nun ja, das ist IMO nicht so ganz einfach, zumindest mein XL2002
speichert immer die ganze Mappe neu ab.

Im Prinzip gibt es 2 Methoden:
a.) Datei via SaveCopyAs speichern, die neue Datei öffnen und alle
anderen Blàtter löschen.
b.) Neue Mappe erzeugen, das aktuelle Blatt kopieren, alle anderen
Blàtter löschen und die neue Datei dann speichern.

Mir erscheint b.) sinnvoller, allerdings gibt es je nach Excel-Version
Limitierungen beim Kopieren von Blàttern.
http://www.xlam.ch/xlimits/excel-new.htm

Andreas.

Sub SpeicherMirsAlsNeueMappe()
Dim wksA As Worksheet
Dim wbkNeu As Workbook, wbkAlt As Workbook
Dim vntPathAndFile As Variant
Dim I As Integer

Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")

vntPathAndFile = Application.GetSaveAsFilename( _
InitialFileName:= _
fs.GetBaseName(ActiveWorkbook.Name) & " - " & _
wksA.Name & " -" & _
Format(Now, " yyyy-mm-dd") & ".xls", _
FileFilter:="Excel Files(*.xls), *.xls", _
Title:="Speichern als")

If Not vntPathAndFile = False Then
'Aktuelles Blatt merken
Set wksA = ActiveSheet
'Aktuelle Mappe merken
Set wbkAlt = ActiveWorkbook
'Neue Mappe erzeugen
Set wbkNeu = Workbooks.Add
'Das Blatt an erste Stelle kopieren
wksA.Copy wbkNeu.Sheets(1)
'Alle anderen (leeren) Blàtter löschen
Application.DisplayAlerts = False
For I = wbkNeu.Sheets.Count To 2 Step -1
wbkNeu.Sheets(I).Delete
Next
Application.DisplayAlerts = True
'Neue Datei speichern
wbkNeu.SaveAs vntPathAndFile
'Neue Datei schließen
wbkNeu.Close
End If
End Sub

Ähnliche fragen