AW: Datei sichern
19.01.2007 11:43:30
fcs
Hallo Odje,
wenn du nur den Inhalt des Druckbereichs der Blätter in der Arbeitsmappe in einer Sicherungskopie speichern willst, dann muss du die Inhalte schrittweise in eine neue Arbeitsmappe übertragen.
Alternativ kannst du auch deine gespeicherte Sicherungskopie wieder per Makro öffnen und alle Inhalte die du nicht benötigst löschen und die Kopie wieder speichern.
Gruß
Franz
Sub sicherung()
Dim strDatName As String, wbKopie As Workbook
With ThisWorkbook
strDatName = "D:\" & Left(.Name, Len(.Name) - 4) & _
Format(Now, "_DD.MM.YY_hhmmss") & ".xls"
.SaveCopyAs strDatName
End With
Set wbKopie = Application.Workbooks.Open(Filename:=strDatName)
'... hier aufgezeichneten Code mit Löschaktionen in Kopie einfügen
'Beispiel
Sheets("Muster1").Select
ActiveSheet.Shapes("CommandButton1").Select
Selection.Delete
Columns("H:H").Select
Selection.ClearContents
Rows("1:3").Select
Selection.ClearContents
Range("A1").Select
'Sicherungskopie Speichern und schließen
wbKopie.Save
wbKopie.Close
End Sub
Sub sicherung_VarianteAlt()
'Für ältere Excelversionen
Dim wbThis As Workbook, wbSicherung As Workbook, I As Integer
Dim wksThis As Worksheet, wksSicherung As Worksheet, Bereich As Range, Zelle As Range
Set wbThis = ThisWorkbook
'Neue Mappe mit einer Tabelle anlegen
Set wbSicherung = Application.Workbooks.Add(xlWBATWorksheet)
'ggf. zusätzliche leere Blätter anlegen
For I = 2 To wbThis.Worksheets.Count
wbSicherung.Worksheets.Add After:=wbSicherung.Sheets(I - 1)
Next
For I = 1 To wbThis.Worksheets.Count
Set wksThis = wbThis.Worksheets(I)
Set wksSicherung = wbSicherung.Worksheets(I)
wksSicherung.Activate
'Tabellennamen in Sicherung übernehemn
wksSicherung.Name = wksThis.Name
If wksThis.PageSetup.PrintArea = "" Then 'kein Druckbereich festgelegt
Set Bereich = wksThis.UsedRange
Else
Set Bereich = wksThis.Range(wksThis.PageSetup.PrintArea)
End If
'Spaltenbreiten in Sicherung einstellen
For Each Zelle In wksThis.Range(Bereich.Cells(1, 1), Bereich.Cells(1, Bereich.Columns.Count))
wksSicherung.Columns(Zelle.Column - Bereich.Column + 1).ColumnWidth = Zelle.EntireColumn.ColumnWidth
Next
'Formate und Werte kopieren
Bereich.Copy
wksSicherung.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
wksSicherung.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
wksSicherung.Cells(1, 1).Select
Next
wbSicherung.SaveAs "D:\" & Left(wbThis.Name, Len(wbThis.Name) - 4) & _
Format(Now, "_DD.MM.YY_hhmmss") & ".xls"
End Sub
Sub sicherung_Variante2003()
'Für Excel 2003
Dim wbThis As Workbook, wbSicherung As Workbook, I As Integer
Dim wksThis As Worksheet, wksSicherung As Worksheet, Bereich As Range, Zelle As Range
Set wbThis = ThisWorkbook
'Neue Mappe mit einer Tabelle anlegen
Set wbSicherung = Application.Workbooks.Add(xlWBATWorksheet)
'ggf. zusätzliche leere Blätter anlegen
For I = 2 To wbThis.Worksheets.Count
wbSicherung.Worksheets.Add After:=wbSicherung.Sheets(I - 1)
Next
For I = 1 To wbThis.Worksheets.Count
Set wksThis = wbThis.Worksheets(I)
Set wksSicherung = wbSicherung.Worksheets(I)
wksSicherung.Activate
'Tabellennamen in Sicherung übernehemn
wksSicherung.Name = wksThis.Name
If wksThis.PageSetup.PrintArea = "" Then 'kein Druckbereich festgelegt
Set Bereich = wksThis.UsedRange
Else
Set Bereich = wksThis.Range(wksThis.PageSetup.PrintArea)
End If
'Formate und Werte kopieren
Bereich.Copy
wksSicherung.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
wksSicherung.Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
wksSicherung.Cells(1, 1).Select
Next
wbSicherung.SaveAs "D:\" & Left(wbThis.Name, Len(wbThis.Name) - 4) & _
Format(Now, "_DD.MM.YY_hhmmss") & ".xls"
End Sub