XL 2019 Sauvegarde automatique

[pierrelcq]

Bonjour,

J'utilise un code pour sauvegarder automatiquement et pour supprimer les anciennes versions de sauvegarde automatique.

Il fonctionne plutôt bien mais j'ai deux problèmes.

1- Les macros ne sont pas sauvegardés dans le fichier excel qui est enregistré automatiquement tout les x temps.

2- J'ai essayé de supprimer la sauvegarde automatiquement et la suppression des vieilles archives au démarrage d'EXCEL parce que ça fait pas mal lagger mais porque je supprime ces deux lignes, il n'y a plus du tout de sauvegarde automatique après ça, comme si le workbook_open était le point de lancement


Voila je vous remercie pour votre aide, très belle journée

Pierre

-------------------------------------------------------------------------------------------
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
ActiveWorkbook.Unprotect Password:="condeordolog"
Sheets("TDB S").Visible = xlVeryHidden
Sheets("TDB S+1").Visible = xlVeryHidden
ActiveWorkbook.Protect Password:="condeordolog", Structure:=True, Windows:=False
End Sub


Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.OnTime ProchaineFois, "ThisWorkbook.Sauvegarder", , False
On Error GoTo 0
supprimerVieux
If RotationId > 0 Then
Application.OnTime RotationId, "Rotation", , False
Application.StatusBar = ""
RotationId = Empty
End If
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

--------------------------------------------------------------------------------------------------

 

[youky(BJ)]

Bonjour Pierre,
J'avais fait ce fichier exemple et le propose car il répond un peu à ta question
Les macros dans ce fichier font que à chaque enregistrement un fichier est créé dans le dossier MySave . Ce dossier MySave ne conserve que les 5 derniers fichiers enregistrés.
Il sera donc toujours possible de retrouver les 5 dernières versions
Bon si tu veux tester enregistre ce fichier dans un dossier et crée dans ce dossier un dossier MySave
Sinon ca marche pas.
Bruno