Incrémenter date nom de fichier excel

Sub XXX()
Dim Nom_Fichier As String          'Nom du fichier
Dim Extension As String            'Extension du fichier

  'Ancien nom
  Nom_Fichier = ThisWorkbook.Name
  Extension = Mid(Nom_Fichier, InStrRev(Nom_Fichier, "."))
  Nom_Fichier = Left(Nom_Fichier, InStrRev(Nom_Fichier, " "))
  'Nouveau nom
  Nom_Fichier = Nom_Fichier & Format(Date, "yyyy-mm-dd") & Extension
  On Error GoTo ErrorHandler
  ActiveWorkbook.SaveAs Filename:=Nom_Fichier
  On Error GoTo 0

Exit Sub

ErrorHandler:          'Routine de gestion d'erreur.
Select Case Err.Number
  Case 1004
    'Le fichier est déjà ouvert ou l'enregistrement à été annulé
    If Err.Description = "La méthode 'SaveAs' de l'objet '_Workbook' a échoué" Then
      Resume Next
    Else
      MsgBox "L'enregistrement à échoué :" & vbCr & vbCr & Err.Description, vbInformation
      Resume Next
    End If
  Case Else
    MsgBox Err.Description, vbCritical
    Stop
    Resume Next
End Select

End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim Nom_Fichier As String          'Nom du fichier
Dim Extension As String            'Extension du fichier

  'Ancien nom
  Nom_Fichier = ThisWorkbook.FullName
  Extension = Mid(Nom_Fichier, InStrRev(Nom_Fichier, "."))
  Nom_Fichier = Left(Nom_Fichier, InStrRev(Nom_Fichier, " "))
  'Nouveau nom
  Nom_Fichier = Nom_Fichier & Format(Date, "yyyy-mm-dd") & Extension
  'Enregistrer une copie
  ThisWorkbook.SaveCopyAs Nom_Fichier
  'Ouvrir la copie
  Workbooks.Open Nom_Fichier
  'Ne pas enregistrer l'original
  Cancel = True
  'Fermer l'original sans l'enregistrer
  ThisWorkbook.Saved = True
  ThisWorkbook.Close
 
End Sub