Hallo,

wenn die Sub Speichern durch meine Funktion FileSaveAs ersetzt wird, dann wird beim Speichern bei Bedarf eine Siicherungskopie angelegt:

''' <summary>
''' Speichert aktuelle Arbeitsmappe ab (mit DialogBox "Speichern unter")
''' </summary>
''' <returns>
''' Type: Boolean
''' True = Speichervorgang erfolgreich abgeschlossen
''' False = Speichervorgang nicht durchgeführt
''' </returns>
''' <remarks>
''' Falls der Anwender die Originaldatei überschreiben will, werden folgende Aktionen durchgeführt:
''' - die derzeitige Aktive Arbeitsmappe im %Temp% Verzeichnis speichern
''' - die Originaldatei verschieben in den Unterordner "Sik"
''' - verschieben der im %temp% Verzeichnis gespeicherten Arbeitsmappe in den ursprünglichen Ordner
''' </remarks>
Function FileSaveAs() As Boolean
    Dim varResult As Variant
    
    ' Mit Verweis auf Mirosoft Scripting Runtime
    Dim objFSO As New Scripting.FileSystemObject
    ' Alternativ Late Binding:
    ' ========================
    'Dim objFSO As Object
    'Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    Dim strFilePathOrig As String
    Dim strFilePathSik As String
    Dim strTMPFile As String
    strFilePathSik = ActiveWorkbook.Path & Application.PathSeparator & "sik" & Application.PathSeparator & ActiveWorkbook.Name
    strFilePathOrig = ActiveWorkbook.Path & Application.PathSeparator & ActiveWorkbook.Name
    varResult = Application.GetSaveAsFilename(InitialFileName:=strFilePathOrig, FileFilter:= _
        "Excel Arbeitsmappe (*.xlsx), *.xlsx, Excel Arbeitsmappe mit Makros (*.xlsm), *.xlsm", _
        FilterIndex:=IIf(ActiveWorkbook.HasVBProject, 2, 1))
    If Not varResult = False Then
        If LCase(varResult) = LCase(strFilePathOrig) Then
            ' Die aktuelle Datei als temporäre Datei speichern
            
            strTMPFile = Environ("TEMP") & "\Temp.xls" & IIf(ActiveWorkbook.HasVBProject, "m", "x")
            If objFSO.FileExists(strTMPFile) Then
                Kill strTMPFile
            End If
            ActiveWorkbook.SaveAs strTMPFile
            ActiveWorkbook.Close
            ' Original verschieben
            If Not objFSO.FolderExists(objFSO.GetParentFolderName(strFilePathSik)) Then
                MkDir objFSO.GetParentFolderName(strFilePathSik)
            End If
            If objFSO.FileExists(strFilePathSik) Then
                Kill strFilePathSik
            End If
            objFSO.MoveFile strFilePathOrig, strFilePathSik
            
            ' Verschieben der Temporären Datei zur Original-Datei
            objFSO.MoveFile strTMPFile, strFilePathOrig
            Application.Workbooks.Open strFilePathOrig
            FileSaveAs = True
        End If
    End If
End Function

Diese Funktion muss mit

call FileSaveAs()

im Sub Workbook_BeforeSave aufgerufen werden. Wichtig ist es, dass der Parameter CAncel weiterhin auf True gesetzt wird.

Der Rückgabewert von der Funktion FileSaveAs kann bei Bedarf ausgewertet werden, um den Benutzer darauf hinzuweisen, dass die Speicherung erfolgreich abgeschlossen (oder abgebrochen) wurde.

VG, BigBen