Effacer les sauvegardes automatiquement VBA
Bonjour a tous
j'ai encore besoin de vous
j'ai un classeur qui effectue une sauvegarde dans un dossier a chaque fois que je le ferme ca c'est tout bon
par contre si je le ferme 10 fois dans la journée je me retrouve avec 10 sauvegardes comment faire pour qu'il garde un nombre prédéfini de sauvegarde
merci d'avance
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'declareation des variables
Dim Nomdossier As String
Dim Nomfichier As String
'affectation des variables
Nomdossier = "D:\sauvegarde_auto_classeur\"
'désactive les messages d'alertes
Application.DisplayAlerts = False
' on créé le nom du fichier de backup
Nomfichier = Day(Date) & "-" & Month(Date) & "-" & Year(Date) & "-" & Format(Time, "hh-mm-ss") & "-" & "sauvegarde prog.xlsm"
' on sauvegarde le fichier de backup
ActiveWorkbook.SaveCopyAs Nomdossier & Nomfichier
'on affiche un message de comfirmation
MsgBox "Fichier de sauvegarde : " & Nomfichier & vbNewLine & " dans le dossier : " & Nomdossier, vbOKOnly + vbInformation, "confirmation"
End Sub
exemple les 5 dernière
si joint le code pour la sauvegarde
Bonjour,
A adapter :
Option Explicit
Sub TestVersionsFichiers()
Dim I As Integer, NbASauvegarder As Integer, NbVersions As Integer
Dim Chemin As String
NbASauvegarder = 5
Chemin = "XXXX\" ' A adapter
NbVersions = VersionsFichiers(Chemin, "Toto1.pdf")
If NbVersions > NbASauvegarder Then
For I = 1 To NbVersions - NbASauvegarder
SupprimerFichiers Chemin, "Toto1.pdf" ' A adapter
Next I
End If
End Sub
Function VersionsFichiers(ByVal RepertoireFichier As String, ByVal ChaineCommuneFichier As String) As Integer
Dim Fso As Object, FolderEnCours As Object, FichierEnCours As Object
VersionsFichiers = 0
Set Fso = CreateObject("Scripting.FileSystemObject")
If Fso.FolderExists(RepertoireFichier) Then
Set FolderEnCours = Fso.GetFolder(RepertoireFichier)
For Each FichierEnCours In FolderEnCours.Files
If InStr(1, FichierEnCours.Name, "-", vbTextCompare) > 0 _
And InStr(1, FichierEnCours.Name, ChaineCommuneFichier, vbTextCompare) > 0 Then
VersionsFichiers = VersionsFichiers + 1
End If
Next FichierEnCours
End If
Set FolderEnCours = Nothing: Set Fso = Nothing
End Function
Sub SupprimerFichiers(ByVal RepertoireFichier As String, ByVal ChaineCommuneFichier As String)
Dim Fso As Object, FolderEnCours As Object, FichierEnCours As Object
On Error GoTo Fin
Set Fso = CreateObject("Scripting.FileSystemObject")
If Fso.FolderExists(RepertoireFichier) Then
Set FolderEnCours = Fso.GetFolder(RepertoireFichier)
For Each FichierEnCours In FolderEnCours.Files
If InStr(1, FichierEnCours.Name, "-", vbTextCompare) > 0 _
And InStr(1, FichierEnCours.Name, ChaineCommuneFichier, vbTextCompare) > 0 Then
Fso.DeleteFile (FichierEnCours)
GoTo Fin
End If
Next FichierEnCours
End If
GoTo Fin
Fin:
Set FolderEnCours = Nothing: Set Fso = Nothing
End Sub
merci pour ce boulo
mais ca ne marche pas j'ai pas de message d'erreur
je me suis dit que mes nom de fichier trop galère (17-5-2022-09-59-25-sauvegarde facturation.xlsm : 17-5-2022-13-10-01-sauvegarde facturation.xlsm )
pour le teste j'ai renommer les 20 fichiers en (1toto.xlsm : 2toto.xlsm : 3toto.xlsm............ )
rien a faire
Non, il faut la même syntaxe que vos fichiers :
17-5-2022-09-59-25-toto.xlsm, 1-toto.xlsm
La présence du tiret est nécessaire :
If InStr(1, FichierEnCours.Name, "-", vbTextCompare) > 0
cool ca fonctionne je ne suis pas aller en profondeur ton code
si j'ai bien compris il supprime les fichiers par ordre alphabétique
si c'est le cas il faut que je modifie le code pour la création des sauvegardes puisque mais fichier commence par une date
exemple : 5-6-2022-* : 15-5-2022-* : 17-6-2022-* : 18-6-2022 :19-5-2022 : 20-6-2022 : 21-6-2022
il vas donc supprimer les deux en bleu alors que les plus ancien sont les 2 en vert si dessous
5-6-2022-* : 15-5-2022-* : 17-6-2022-* : 18-6-2022 :19-5-2022 : 20-6-2022 : 21-6-2022
je pense qu'il fauque je modifie c'cette parti de mon code
Nomfichier = Day(Date) & "-" & Month(Date) & "-" & Year(Date) & "-" & Format(Time, "hh-mm-ss") & "-" & "sauvegarde prog.xlsm"
peut tu me confirmer tous ca
merci pour ton boulot c'est top
bonne journée
Il faut que tes fichiers commencent par l'année, le mois, le jour.
oui tout a fait
encore merci a toi
Bonjour,
une autre manière de procéder pour ne garder que les n fichiers les plus récents :
Dans un module standard :
Sub Nombre_Fichiers()
NbFicMax = InputBox("Combien de fichiers à garder ?", , 8)
If NbFicMax = "" Then Exit Sub
DeleteEnTrop (NbFicMax)
End Sub
Sub DeleteEnTrop(NbFicMax As Integer)
Dim Fic As String
Dim Tabl() As Variant
Dim i As Integer
ReDim Tabl(1, 0)
Fic = Dir(Chemin)
Do While Fic <> ""
ReDim Preserve Tabl(1, UBound(Tabl, 2) + 1)
Tabl(0, UBound(Tabl, 2)) = Fic
Tabl(1, UBound(Tabl, 2)) = FileDateTime(Chemin & Fic)
Fic = Dir
Loop
If UBound(Tabl, 2) > NbFicMax Then
Tri Tabl, 1, UBound(Tabl, 2) 'Macro de tri à bulles
For i = UBound(Tabl, 2) To NbFicMax + 1 Step -1
Kill Chemin & Tabl(0, i)
Next i
End If
End Sub
et enfin :
Sub Tri(ByRef Liste As Variant, ByVal Bas As Long, ByVal Haut As Long)
Dim i As Long, j As Long
Dim Milieu As Variant, Echange As Variant
i = Bas
j = Haut
Milieu = Liste(1, Int(Bas + Haut) / 2)
Do
While Liste(1, i) > Milieu
i = i + 1
Wend
While Milieu > Liste(1, j)
j = j - 1
Wend
If i <= j Then
Echange = Liste(1, i)
Liste(1, i) = Liste(1, j)
Liste(1, j) = Echange
Echange = Liste(0, i)
Liste(0, i) = Liste(0, j)
Liste(0, j) = Echange
i = i + 1
j = j - 1
End If
Loop Until i > j
If Bas < j Then Tri Liste, Bas, j
If i < Haut Then Tri Liste, i, Haut
End Sub
Il suffit d'appeler Nombre_Fichiers dans le WorkBook_Open, ou BeforeClose et de choisir le nombre de fichiers à conserver. Possible également de fixer une fois pour toutesle nombre de fichiers à garder.