Cyber, troque a rotina pela a abaixo e veja se é isto.

Private Sub Workbook_BeforeClose(Cancel As Boolean)
 
    With Application
        .CommandBars("Cell").Reset
    End With
    
    Application.DisplayAlerts = False
    
    Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean
    
    Dim NewFolderName  As String
    Dim Backup2FileName  As String
    
    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
            
                'BACKUP 2
                'Captamos somente o nome do arquivo e redefinimos a extensão
                Backup2FileName = awb.Name
                Backup2FileName = Left(Backup2FileName, (Len(Backup2FileName) - 4))
                Backup2FileName = Backup2FileName & ".bak"
                
                'Define o Novo Caminho para a segunda Cópia
                NewFolderName = "C:Backup_Contabilidade"
                ActiveWorkbook.SaveCopyAs NewFolderName & "" & Backup2FileName
            
        End If
    
NotAbleToSave:

    Set awb = Nothing
    Application.StatusBar = False
    If Not OK Then
        MsgBox "Backup Copy Not Saved!", vbExclamation, ThisWorkbook.Name
    End If
    ThisWorkbook.Save
End Sub

[]s

Boas

Muito obrigado está exelente.
Obrigado é isto mesmo.

Bom dia!!

Eu não sei ao certo mas, seria outra maneira...

Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    With Application
        .CommandBars("Cell").Reset
    End With
    Application.DisplayAlerts = False
    Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean
    Dim BackupFileName2 As String
    If TypeName(ActiveWorkbook) = "Nothing" Then Exit Sub
    Set awb = ActiveWorkbook
    If awb.Path = "" Then
        Application.Dialogs(xlDialogSaveAs).Show
    Else
        BackupFileName = awb.FullName
        BackupFileName2 = "C:Backup_Contabilidade" & awb.Name
        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"
        End If
        i = 0
        While InStr(i + 1, BackupFileName2, ".") > 0
            i = InStr(i + 1, BackupFileName2, ".")
        Wend
        If i > 0 Then '
            BackupFileName2 = Left(BackupFileName2, i - 1)
            BackupFileName2 = BackupFileName2 & ".bak" '
        End If '
        OK = False
        On Error GoTo NotAbleToSave
        With awb
            Application.StatusBar = "Saving this workbook..."
            .Save
            Application.StatusBar = "Saving this workbook backup..."
            .SaveCopyAs BackupFileName
            Application.StatusBar = "Saving this 2nd workbook backup..."
            .SaveCopyAs BackupFileName2
            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
    ThisWorkbook.Save
End Sub

Obrigado na mesma mas o outro está optimo.
Excelente