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