XL 2010 sauvegarde avec générations

[jpmetge]

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]

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

XL 2016 - enregistrer sur le bureau chaque 5mn classeur actif sous son nom +1

Bonjour à toutes et à tous, Afin d'éviter ou de réduire les risques de pertes de données saisies, je voudrais faire ce qui suit : Enregistrement automatique chaque 5 mn (ou à paramétrer selon besoin) du fichier sous un autre nom actuellement : nom du fichier =...

www.excel-downloads.com

a+

 

[Eric C]

Bonjour le forum
Bonjour à toutes & à tous
Bonjour jpmetge, bonjour CHALET53

Il y a aussi le lien de notre ami Bruno qui se rapproche de la demande et qui peut être adapté :
https://www.excel-downloads.com/thr...iquement-un-fichier-dans-un-dossier.20034219/
Bonne journée à toutes & à tous

 

[job75]

Bonjour jpmetge, CHALET53, Eric C,

Placer tout ce code dans le ThisWorkbook du fichier à sauvegarder :

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]

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]

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 :

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+

 

[jpmetge]

Bonjour à tous
La réponse de Job75 est exactement ce que je recherchais.
Merci à tous ceux qui ont répondu aussi rapidement
Je clos ma demande.

 

[sousou]

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]

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

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

bonne continuation
jcf