Private Sub Workbook_Open()
    reserv
End Sub

Sub reserv()

Dim strPath As String
Dim strDate As String
    Application.ScreenUpdating = False
    strPath = ThisWorkbook.Path
    If Len(Dir(strPath & "\_Резерв\", vbDirectory)) = 0 Then MkDir strPath & "\_Резерв\"
    On Error Resume Next
    x = GetAttr(strPath) And 0
    If Err = 0 Then
        strDate = Format(Now, "yyyy_mm_dd_hh-mm")
        FileNameXls = strPath & "\_Резерв\" & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & "_" & strDate & ".xlsb"
        ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
    Else
        MsgBox "Ошибка сохранения!!!!", vbCritical
    End If
    Application.ScreenUpdating = True
End Sub

Sub reserv()

Dim strPath As String
Dim strDate As String
Dim x
Dim FileNameXls
    Application.ScreenUpdating = False
    strPath = ActiveWorkbook.Path
    If Len(Dir(strPath & "\_Резерв\", vbDirectory)) = 0 Then MkDir strPath & "\_Резерв\"
    On Error Resume Next
    x = GetAttr(strPath) And 0
    If Err = 0 Then
        strDate = Format(Now, "yyyy_mm_dd_hh-mm")
        FileNameXls = strPath & "\_Резерв\" & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & "_" & strDate & ".xlsb"
        ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
    Else
        MsgBox "Ошибка сохранения!!!!", vbCritical
    End If
    Application.ScreenUpdating = True
End Sub

Private Sub Workbook_Open()
    With ThisWorkbook
        Application.Run ("personal.xlsb!reserv")
    End With
End Sub

Private WithEvents app As Application
Private Sub app_WorkbookBeforeSave(ByVal Wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)
    On Error GoTo er
    Dim LastSaved$, Backup$
    LastSaved = Wb.BuiltinDocumentProperties("Last Save Time")
    Backup = Wb.Path & "\" & Replace(LastSaved, ":", ".") & " " & Wb.Name
    If Wb Is Me Or Wb.IsAddin Then Exit Sub
    If Wb.FullName <> Wb.Name And Not SaveAsUI And MsgBox("Сделать бэкап?", 36) = 6 Then
        Shell Join(Array("cmd /c copy ", Wb.FullName, " ", Backup, " /y"), """")
        Do While Dir$(Backup) = ""
            DoEvents
        Loop
    ElseIf SaveAsUI Then
        MsgBox "Тут можно чего-то написать"
    End If
er:
End Sub
Private Sub Workbook_Open()
    Set app = Application
End Sub

Backup = Wb.Path & "\" & Replace(LastSaved, ":", ".") & " " & Wb.Name

strPath = ActiveWorkbook.Path

Private WithEvents app As Application
Private Sub app_WorkbookBeforeSave(ByVal Wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)
    On Error GoTo er
    Dim LastSaved$, Backup$
    LastSaved = Wb.BuiltinDocumentProperties("Last Save Time")
    If Dir(Wb.Path & "\excel_bak\", vbDirectory) = "" Then MkDir (Wb.Path & "\excel_bak\")
    Backup = Wb.Path & "\excel_bak\" & Replace(LastSaved, ":", ".") & " " & Wb.Name
    If Wb Is Me Or Wb.IsAddin Then Exit Sub
    If Wb.FullName <> Wb.Name And Not SaveAsUI Then 'And MsgBox("Сделать бэкап?", 36) = 6 Then
        Shell Join(Array("cmd /c copy ", Wb.FullName, " ", Backup, " /y"), """")
        Do While Dir$(Backup) = ""
            DoEvents
        Loop
    ElseIf SaveAsUI Then
        'MsgBox "Тут можно чего-то написать"
    End If
er:
End Sub
Private Sub Workbook_Open()
    Set app = Application
End Sub