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.