BACKUP von Excel-Datei beim Speichern

Hallo,
ich habe für mein "Problem" (nicht wirklich ein Problem) die so wirklich richtige Lösung bisher nicht gefunden. Habe gegoogelt und es gab einige Vorschläge.
Aber vielleicht hat hier jemand einen schlanken VBA-Code mit dem ich das Vorhaben verwirklichen kann.
Ich möchte beim Speichern meiner Excel-Datei eine Kopie in einem anderen Verzeichnis erstellen. Diese soll als Sicherheitskopie (auch für andere Kollegen) dienen.
Die Originaldatei (mit dem Makro) wird natürlich eine xlsm-Datei sein. Die Sicherheitskopie soll allerdings ohne Makto gespeichert werden, also als xlsx-Datei.
DIe Sicherheitskopie soll den Namen der Original-Datei plus YYYY-MM-DD_hh:mm:ss (der Speicherung) erhalten.
Und...jetzt bin ich unverschämt...ich hätte von diesem Makro gerne auch die Version dass die Sicherungskopie beim Speichern nicht überschrieben wird sondern
eine weitere Kopie angelegt wird.
Ich würde mich freuen wenn hier jemand die passende Lösung hat.
Vielen Dank im Voraus.
tobi

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) On Error GoTo Fehler Dim Pfad As String, Ext1 As String, Ext2 As String, Datei As String, Zeitst As String Dim NName As String, Vers As Boolean 'Version TRUE= mit löschen Vers = TRUE Ext1 = ".xlsm" Ext2 = ".xlsx" Pfad = "E:\excel\Temp\Test\" '**** mit \ NName = Replace(ThisWorkbook.Name, Ext1, "") 'Name ohne Endung Zeitst = Format(Now, " YYYY-MM-DD_hh-mm-ss") Application.EnableEvents = False 'Normales speichern ThisWorkbook.Save Application.DisplayAlerts = False ' Warnung abschalten 'Sicherung speichern ThisWorkbook.SaveAs Filename:=Pfad & NName & Zeitst & Ext2, FileFormat:=xlOpenXMLWorkbook Application.EnableEvents = True If Vers Then 'Löschen alter Sicherungen Datei = Dir(Pfad & NName & "*" & Ext2) Do While Len(Datei) > 0 'Alle Löschen, außer Aktuelle If Datei NName & Zeitst & Ext2 Then Kill Pfad & Datei End If Datei = Dir() ' nächste Datei Loop End If Err.Clear Fehler: Application.EnableEvents = True Application.DisplayAlerts = True If Err.Number 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub

Das Original wird wieder geöffnet...


Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
On Error GoTo Fehler
Dim Pfad  As String, Ext1 As String, Ext2 As String, Datei As String, Zeitst As String
Dim NName As String, Vers As Boolean, WB1 As String, WB2 As Workbook
'Version True= mit löschen
Vers = True
Ext1 = ".xlsm"
Ext2 = ".xlsx"
Pfad = "E:\excel\Temp\Test\" '**** mit \
WB1 = ThisWorkbook.FullName
Cancel = True
NName = Replace(Dir(WB1), Ext1, "") 'Name ohne Endung
Zeitst = Format(Now, " YYYY-MM-DD_hh-mm-ss")
Application.EnableEvents = False
'Normales speichern
ThisWorkbook.Save
Application.DisplayAlerts = False ' Warnung abschalten
'Sicherung speichern
ThisWorkbook.SaveAs Filename:=Pfad & NName & Zeitst & Ext2, FileFormat:=xlOpenXMLWorkbook
Set WB2 = ActiveWorkbook 'Das Neue
Application.EnableEvents = True
If Vers Then
'Löschen alter Sicherungen
Datei = Dir(Pfad & NName & "*" & Ext2)
Do While Len(Datei) > 0
'Alle Löschen, außer Aktuelle
If Datei  WB2.Name Then
Kill Pfad & Datei
End If
Datei = Dir() ' nächste Datei
Loop
End If
' Kopie schließen / Original öffnen
Workbooks.Open WB1
WB2.Close False
Err.Clear
Fehler:
Application.EnableEvents = True
Application.DisplayAlerts = True
If Err.Number  0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

BACKUP von Excel-Datei beim Speichern

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread