If you're working on an important workbook and wish to keep a running list with separate incremental backups, you can copy this code to your 'ThisWorkbook' section in the VBE

Note: This will not be executed if the file is opened as READONLY (what's the point, right?)
Note: A backup is automatically made upon opening the workbook (not if the file was opened READONLY)
Note: This creates a full backup of the workbook including all macros
Note: Backups are identified with a Date and Time suffix helping to identify them
Note: Upon Saving or Closing you are prompted for an optional comment which might help to identify the changes you made during your edit.


Setup: Change the BackupDir const to your target folder (which must exist)


'**** Place in ThisWorkbook
'**** Copy from here down

Option Explicit

'Author: Greg Glynn

Const BackupDir = "P:\Backups\" '*** Change this to your backups folder which can be different from your workbook folder

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim BackupFileName As String, BackupDateTime As String, BackupUser As String, BackupFileType As String
Dim sh As Worksheet, wkb As Workbook
Dim Comment As String

Comment = ""

Application.Caption = "*** Auto Backup ***"
DoEvents
Application.EnableEvents = False
Application.ScreenUpdating = False

'Backup the data if the sheet was not opened in ReadOnly mode
If ThisWorkbook.ReadOnly = False Then

Comment = InputBox("Add a comment?")
If Comment < "" Then
Comment = " - " & Replace(Comment, "/", "-")
End If

'Create a backup
BackupFileName = Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".xls") - 1)
BackupDateTime = " " & Format(Now(), "YYYY-MM-DD hh-mm-ss")
BackupUser = " " & Environ$("Username")
BackupFileType = "." & Mid(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".xls") + 1, 999)
On Error Resume Next
ActiveWorkbook.SaveCopyAs BackupDir & BackupFileName & BackupDateTime & BackupUser & Comment & BackupFileType

Application.StatusBar = "Saved " & BackupFileName & " " & Format(FileLen(BackupDir & BackupFileName & BackupDateTime & BackupUser & Comment & BackupFileType), "#,#") & " bytes."
On Error Resume Next
'Will be saved anyway by virtue of the "Workbook_BeforeSave" function
'ActiveWorkbook.Save

End If

Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Caption = ""
End Sub

Private Sub Workbook_Open()

Dim BackupFileName As String, BackupDateTime As String, BackupUser As String, BackupFileType As String
Dim sh As Worksheet, wkb As Workbook

Application.Caption = "*** Auto Backup ***"
DoEvents
Application.EnableEvents = False
Application.ScreenUpdating = False

'Backup the data if the sheet was not opened in ReadOnly mode
If ThisWorkbook.ReadOnly = False Then

'Create a backup
BackupFileName = Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".xls") - 1)
BackupDateTime = " " & Format(Now(), "YYYY-MM-DD hh-mm-ss")
BackupUser = " " & Environ$("Username")
BackupFileType = "." & Mid(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".xls") + 1, 999)
On Error Resume Next
ActiveWorkbook.SaveCopyAs BackupDir & BackupFileName & BackupDateTime & BackupUser & BackupFileType
On Error Resume Next
ActiveWorkbook.Save

End If

Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Caption = ""

End Sub