» Save a workbook backup using VBA in Microsoft Excel

VBA macro tip contributed by Erlandsen Data Consulting offering Microsoft Excel Application development, template customization, support and training solutions The macro below can be used to create a backup copy of the active workbook.
The backup workbook will be stored in the same folder as the active workbook with the file extension ".BAK".

Sub SaveWorkbookBackup()
Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean
    If TypeName(ActiveWorkbook) = "Nothing" Then Exit Sub
    Set awb = ActiveWorkbook
    If awb.Path = "" Then
        Application.Dialogs(xlDialogSaveAs).Show
    Else
        BackupFileName = awb.FullName
        i = 0
        While InStr(i + 1, BackupFileName, ".") > 0
            i = InStr(i + 1, BackupFileName, ".")
        Wend
        If i > 0 Then BackupFileName = Left(BackupFileName, i - 1)
        BackupFileName = BackupFileName & ".bak"
        OK = False
        On Error GoTo NotAbleToSave
        With awb
            Application.StatusBar = "Saving this workbook..."
            .Save
            Application.StatusBar = "Saving this workbook backup..."
            .SaveCopyAs BackupFileName
            OK = True
        End With
    End If
NotAbleToSave:
    Set awb = Nothing
    Application.StatusBar = False
    If Not OK Then
        MsgBox "Backup Copy Not Saved!", vbExclamation, ThisWorkbook.Name
    End If
End Sub

The macro below can be used to save a copy of the active workbook to a floppy disk in
station A:\. The backup copy will have the same name as the active workbook.

Sub SaveWorkbookBackupToFloppyA()
Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean
    If TypeName(ActiveWorkbook) = "Nothing" Then Exit Sub
    Set awb = ActiveWorkbook
    If awb.Path = "" Then
        Application.Dialogs(xlDialogSaveAs).Show
    Else
        BackupFileName = awb.Name
        OK = False
        On Error GoTo NotAbleToSave
        If Dir("A:\" & BackupFileName) <> "" Then
            Kill "A:\" & BackupFileName
        End If
        With awb
            Application.StatusBar = "Saving this workbook..."
            .Save
            Application.StatusBar = "Saving this workbook backup..."
            .SaveCopyAs "A:\" & BackupFileName
            OK = True
        End With
    End If
NotAbleToSave:
    Set awb = Nothing
    Application.StatusBar = False
    If Not OK Then
        MsgBox "Backup Copy Not Saved!", vbExclamation, ThisWorkbook.Name
    End If
End Sub