XL 2019 Petit détail concernant la sauvegarde automatique

Bonjour,

J'utilise une sauvegarde automatique de mon fichier excel qui marche parfaitement.

Je crois qu'il doit manquer quelque chose car elle n'enregistre juste pas les macros et c'est un peu genant

On peut retrouver le code ci-dessous ou directement en pièce jointe via le fichier excel.

Merci pour votre aide.

Option Explicit

Const scheminBackUp = "G:\Pierre\Sauvegarde fichier excel\"
Const Intervalle = "00:45:00"
Const PlusVieuxQueXXheures = 1
Dim ProchaineFois As Date

Private Sub Workbook_Open()
On Error Resume Next: MkDir "G:\Pierre\Sauvegarde fichier excel": On Error GoTo 0
Sauvegarder
supprimerVieux
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.OnTime ProchaineFois, "ThisWorkbook.Sauvegarder", , False
On Error GoTo 0
supprimerVieux
End Sub


Sub Sauvegarder()
Dim cheminBackUp$, nomfic$, mots, classeur As Workbook

On Error Resume Next
Application.ScreenUpdating = False
With ThisWorkbook
If ProchaineFois > TimeValue("00:00:00") Then Application.OnTime ProchaineFois, "ThisWorkbook.Sauvegarder", , False
cheminBackUp = scheminBackUp
If Right(cheminBackUp, 1) <> "\" Then cheminBackUp = cheminBackUp & "\"
nomfic = Left(.Name, Len(ThisWorkbook.Name) - 1 - Len(Split(.Name, ".")(UBound(Split(.Name, ".")))))
nomfic = nomfic & Format(Now, " (mmm-dd-yyyy hh""h""mm""m""ss""s"")")
Application.DisplayAlerts = False
.Save
.SaveCopyAs cheminBackUp & nomfic
Application.EnableEvents = False
Set classeur = Workbooks.Open(cheminBackUp & nomfic)
classeur.SaveAs cheminBackUp & nomfic & ".xlsx", FileFormat:=xlOpenXMLWorkbook
classeur.Close
Kill cheminBackUp & nomfic
Application.EnableEvents = True
ProchaineFois = Now() + TimeValue(Intervalle)
Application.OnTime ProchaineFois, "ThisWorkbook.Sauvegarder", , True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
On Error GoTo 0
End Sub

Sub supprimerVieux()
Dim cheminBackUp$, nomfic$, mots, classeur As Workbook, xfic
Dim DateLimite As Date, DateFic, HeureFic, s, j

With ThisWorkbook
DateLimite = Now() - PlusVieuxQueXXheures / 24#
cheminBackUp = scheminBackUp
If Right(cheminBackUp, 1) <> "\" Then cheminBackUp = cheminBackUp & "\"
nomfic = Left(.Name, Len(ThisWorkbook.Name) - 1 - Len(Split(.Name, ".")(UBound(Split(.Name, ".")))))
xfic = Dir(cheminBackUp & nomfic & "*.xlsx")
Do While xfic <> ""
On Error Resume Next
s = Split(Split(xfic, "(")(1), ")")(0)
s = Replace(s, "-", " "): s = Replace(s, "h", " ")
s = Replace(s, "m", " "): s = Replace(s, "s", " ")
j = Split(s)
DateFic = CDate(j(1) & "-" & j(0) & "-" & j(2))
HeureFic = TimeSerial(j(3), j(4), j(5))
DateFic = DateFic & " " & HeureFic
DateFic = CDate(DateFic)
If Err.Number = 0 Then If DateFic <= DateLimite Then Kill cheminBackUp & xfic
On Error GoTo 0
xfic = Dir
Loop
End With
End Sub