Excel: Sicherungskopie vor ausführen eines Makros

Option Explicit
'********************************************************************
Sub Excel_DateiSichernUndFilesInProjekt()
 ->*** Eine Kopie der aktuelle Mappe wird
 ->*** im Pfad C:\temp\Privat\Aktivitaeten  & Date
 ->*** gesichert. Das Verzeichnis Aktivitaeten  & Date
 ->*** wird, wenn nicht vorhanden angelegt.
 ->***
 ->*** Die dazugehörigen Exceldateien im Verzeichnis
 ->*** c:\Projekt ebenfalls
 ->***
  
 ->Sicherungpfad
  Const c_SicherungspfadAllgemein = C:\temp\Privat
  Const c_SicherungPfadTag = Aktivitaeten
  Const c_ProjektVerz = c:\Projekt
  
  Dim s_Dateiname_Full As String
  Dim s_DateinameSicherung_Full As String
  Dim s_PfadSicherung As String
    
 ->Datei speichern und eigenen vollen Pfad/Dateinamen merken
  ActiveWorkbook.Save
  s_Dateiname_Full = ActiveWorkbook.FullName
  
 ->Sicherungpfad prüfen
  If  = Dir(c_SicherungspfadAllgemein, vbDirectory) Then
    MsgBox (Sicherungspfad  & c_SicherungspfadAllgemein &  nicht vorhanden.)
    Exit Sub
  End If
  
 ->Sicherungsverzeichnis anlegen, wenn noch nicht vorhanden
  s_PfadSicherung = c_SicherungspfadAllgemein & \ & c_SicherungPfadTag & Date
  If  = Dir(s_PfadSicherung, vbDirectory) Then MkDir s_PfadSicherung
  
  Application.ScreenUpdating = False
  
 ->aktuelle Datei sichern, ggf. vorhandene Sicherung überschreiben
  s_DateinameSicherung_Full = s_PfadSicherung & \ & ActiveWorkbook.Name
  Application.DisplayAlerts = False
  ActiveWorkbook.SaveAs FileName:=s_DateinameSicherung_Full
  Application.DisplayAlerts = True
  
 ->wieder als bisherige Datei speichern
  Application.DisplayAlerts = False
  ActiveWorkbook.SaveAs FileName:=s_Dateiname_Full
  Application.DisplayAlerts = True
  
  Application.ScreenUpdating = True
  
 ->Jetzt noch die Dateien aus dem Projektverzeichnis sichern
  Call ExcelFilesAusDirInSicherungsverzeichnisSichern( _
        c_ProjektVerz, s_PfadSicherung, s_Dateiname_Full)
        
End Sub
'********************************************************************
Private Function ExcelFilesAusDirInSicherungsverzeichnisSichern( _
                      s_Pfad As String, s_SicherungsPfad As String, s_Dateiname_Full As String)

  Dim s_QuellDatei As String, s_ZielDatei As String, x As Long

  With Application.FileSearch
    .NewSearch
    .LookIn = s_Pfad
    .SearchSubFolders = False
    .FileType = msoFileTypeExcelWorkbooks
    If .Execute() > 0 Then
      For x = 1 To .FoundFiles.Count
        s_QuellDatei = .FoundFiles(x)
        If s_QuellDatei <> s_Dateiname_Full Then
          s_ZielDatei = _
            s_SicherungsPfad & \ & DateiNameAusFullName(.FoundFiles(x))
          FileCopy s_QuellDatei, s_ZielDatei
        End If
      Next x
    End If
  End With
End Function
'********************************************************************
Private Function DateiNameAusFullName(s_Fullname As String) As String
  Dim x As Long
  
  DateiNameAusFullName = 
  
  For x = Len(s_Fullname) To 1 Step -1
    If Mid(s_Fullname, x, 1) = \ Then
      DateiNameAusFullName = Right(s_Fullname, Len(s_Fullname) - x)
      Exit For
    End If
  Next
End Function