SOS Macro ou fonction pour archiver mes données chaque jour

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Archiver
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  Archiver
End Sub

Sub Archiver()
Dim DateEtHeure, Chemin, NomArchive, rep, Fichier, n&

DateEtHeure = Format(Now(), "yyyymmdd") & Format(Time, "hhmmss")
DateEtHeure = DateEtHeure & " le " & Format(Now(), "ddd dd-mmm-yyyy")
DateEtHeure = DateEtHeure & " à " & Format(Time, "hh-mm-ss")

'sauvegarder une copie
rep = MsgBox("Désirez vous sauvegarder une copie ?", _
        vbQuestion + vbDefaultButton1 + vbYesNo)
If rep = vbYes Then
  Chemin = ThisWorkbook.Path
  If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
  NomArchive = "Archive " & DateEtHeure & ".xlsm"
  ThisWorkbook.SaveCopyAs Chemin & NomArchive
  
  'détruire las autres archives du même jour
  ChDir Chemin
  Fichier = Dir("Archive " & Format(Now(), "yyyymmdd") & "*.xlsm")
  Do Until Len(Fichier) = 0 Or n = 10
    If LCase(Fichier) <> LCase(NomArchive) Then Kill Chemin & Fichier
    Fichier = Dir("Archive " & Format(Now(), "yyyymmdd") & "*.xlsm")
    n = n + 1
  Loop
End If

End Sub