XL 2010 sauvegarde avec générations

jpmetge

XLDnaute Nouveau
Bonjour,
Je souhaiterais écrire un code VBA qui à, l'ouverture d'un fichier excel, enregistre une copie datée et qui ne conserve que les 5 dernières générations.
Merci de votre aide
 

CHALET53

XLDnaute Barbatruc
Bonjour
Peut-être que cette discussion pourrait t'apporter une réponse :


a+
 

job75

XLDnaute Barbatruc
Bonjour jpmetge, CHALET53, Eric C,

Placer tout ce code dans le ThisWorkbook du fichier à sauvegarder :
VB:
Private Sub Workbook_Open()
If Me.Name Like "*-*-*-*-*" Then Exit Sub
Dim chemin$, nom$, ext$, x$, dat As Date, fichier$, a(), n%
chemin = Me.Path & "\"
nom = Me.Name
ext = Mid(nom, InStrRev(nom, "."))
x = Len(nom) - Len(ext)
nom = Left(nom, x)
dat = FileDateTime(Me.FullName) 'date/heure du dernier enregistrement
Me.SaveCopyAs chemin & nom & Format(dat, " dd-mm-yy hh-mm-ss") & ext
fichier = Dir(chemin & nom & "*-*-*-*-*.xlsm")
While fichier <> ""
    ReDim Preserve a(n) 'base 0
    a(n) = CDate(Mid(fichier, x + 2, 9) & Replace(Mid(fichier, x + 11, 8), "-", ":"))
    If a(n) <> "" Then n = n + 1
    fichier = Dir
Wend
tri a, 0, UBound(a)
'---on ne garde que les 5 derniers fichiers---
For n = 0 To UBound(a) - 5
    Kill chemin & nom & Format(a(n), " dd-mm-yy hh-mm-ss") & ext
Next
End Sub

Sub tri(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub
A+
 
Dernière édition:

sousou

XLDnaute Barbatruc
Bonjour à tous .
Ma contribution
dans un répertoire de sauvgarde, création et indexation ( 1 à 5) des fichiers
Private Sub Workbook_Open()
Set fso = CreateObject("scripting.filesystemobject")
chemin = ThisWorkbook.Path
repsauv = chemin & "\save\" 'sous-entand q'un répertoire sa ve à été créé
nom = ThisWorkbook.Name
Set repsave = fso.getfolder(repsauv)
'réindexation des fichiers existant
For Each f In repsave.Files
nomdest = Left(f.Name, Len(f.Name) - 5)
ind = Right(nomdest, 1)
If ind = 1 Then f.Delete ' si index 1 le fichier est éffacé
If ind >= 2 Then f.Name = Left(nomdest, Len(nomdest) - 1) & ind - 1 & ".xlsm"
Next

If ind = "" Then ind = 1
myfich = chemin & "\" & nom
newfich = repsauv & Left(nom, Len(nom) - 5) & Year(Date) & Month(Date) & Day(Date) & "heure" & _
Hour(Time) & "-" & Minute(Time) & "-" & Second(Time) & "-" & 5 & ".xlsm"
fso.CopyFile myfich, newfich ' copy de la sauvegarde
End Sub
 

jpmetge

XLDnaute Nouveau
Bonjour,
Pas mal, mais celà ne génère pas le nombre limité de versions de mon fichier.
Bonjour jpmetge, CHALET53, Eric C,

Placer tout ce code dans le ThisWorkbook du fichier à sauvegarder :
VB:
Private Sub Workbook_Open()
If Me.Name Like "*-*-*-*-*" Then Exit Sub
Dim chemin$, nom$, ext$, x$, dat As Date, fichier$, a(), n%
chemin = Me.Path & "\"
nom = Me.Name
ext = Mid(nom, InStrRev(nom, "."))
x = Len(nom) - Len(ext)
nom = Left(nom, x)
dat = FileDateTime(Me.FullName) 'date/heure du dernier enregistrement
Me.SaveCopyAs chemin & nom & Format(dat, " dd-mm-yy hh-mm-ss") & ext
fichier = Dir(chemin & nom & "*-*-*-*-*.xlsm")
While fichier <> ""
    ReDim Preserve a(n) 'base 0
    a(n) = CDate(Mid(fichier, x + 2, 9) & Replace(Mid(fichier, x + 11, 8), "-", ":"))
    If a(n) <> "" Then n = n + 1
    fichier = Dir
Wend
tri a, 0, UBound(a)
'---on ne garde que les 5 derniers fichiers---
For n = 0 To UBound(a) - 5
    Kill chemin & nom & Format(a(n), " dd-mm-yy hh-mm-ss") & ext
Next
End Sub

Sub tri(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub
A+
 

sousou

XLDnaute Barbatruc
re
en théorie si!
A chaque fois que tu ouvre le fichier, il renomme les anciens avec ind-1 et le dernier est copié avec ind 5.
si l'indice est 1 je supprime le fichier
Je vais vérifier
Il me semble que cela fonctionne
 

jcf6464

XLDnaute Occasionnel
Bonjour à vous tous et le forum,

Je viens de voir votre code celui de job75 fonctionne bien,
Pour sousou t'on morceau de code ne fonctionne pas

ce morceau
VB:
If ind >= 2 Then f.Name = Left(nomdest, Len(nomdest) - 1) & ind - 1 & ".xlsm"

bonne continuation
jcf
 

Discussions similaires

Statistiques des forums

Discussions
311 735
Messages
2 082 023
Membres
101 873
dernier inscrit
excellllll