XL 2021 Faire une copie de mon classeur quand "Target" change

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour à toutes et à tous :)

Mon cher Gérard m'avait donné un code à l'occasion de ce fil :

2019, Mon besoin était :
1 sauvegarder toutes les 5 minutes qui sont devenues 30 secondes une copie renommée,
2 pour ne pas encombrer l'ordi de fichiers de ne laisser que les 2 derniers fichiers sauvegardés,
3 de sauvegarder sur le bureau,
Il fonctionne toujours super bien et je l'utilise régulièrement depuis longtemps.
VB:
Option Explicit
Private Sub Workbook_Open()
    Columns("B:B").Select
    Selection.ClearContents
    Range("a2").Select
  
t = Now + 1 / 2880 'délai 1 minute
Application.OnTime t, "Enregistrer" 'lance le processus
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.OnTime t, "Enregistrer", , False 'arrête le processus
End Sub
Option Explicit
Public t# 'mémorise la variable

Sub Enregistrer()
h_mn
Dim chemin$, x$, fichier$, a(), n&
chemin = ThisWorkbook.Path & "\"
x = "XXXXXXX_SauveTravail "
ThisWorkbook.SaveAs chemin & x & Format(Now, "dd-mm-yy hh-mm-ss")
On Error Resume Next
Application.OnTime t, "Enregistrer", , False
t = Now + 1 / 2880 'délai 1 minute
Application.OnTime t, "Enregistrer"
fichier = Dir(chemin & x & "*.xlsm")
While fichier <> ""
    ReDim Preserve a(n) 'base 0
    a(n) = CDate(Mid(fichier, Len(x) + 1, 8) & Replace(Mid(fichier, Len(x) + 9, 9), "-", ":"))
    If a(n) <> "" Then n = n + 1
    fichier = Dir
Wend
tri a, 0, UBound(a)
'---on ne garde que les 2 derniers fichiers---
For n = 0 To UBound(a) - 2
    Kill chemin & x & Format(a(n), "dd-mm-yy hh-mm-ss") & ".xlsm"
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

Encore MERCI Gérard :)

2023, mon besoin a évolué, ce que je souhaiterais :
1 que la sauvegarde ne se fasse qu'au changement (modification d'une cellule - B1 par exemple),
2 que la sauvegarde se mette dans un dossier qui sera sur le bureau ("sauvegarde" par exemple),
3 (inchangé) pour ne pas encombrer l'ordi de fichiers de ne laisser que les 2 derniers fichiers sauvegardés,
4 que la sauvegarde prenne le nom d'origine du fichier ("isiTel_Lionel Sextant 2023 06 13)
4-1seule la partie date étant remplacé par la date et l'heure de sauvegarde,
soit : 2023 06 13 (pas de "." entre les chiffres)
étant remplacé (format aaaa/mm/jj) par 2023 06 13 16:19:39 sans les "."

Pour moi, bricoleur du dimanche, c'est un sacré chantier sachant que je suis loin de comprendre les codes.
Mais je m'y attaque... déjà, après 2 heures de tentatives, mes derniers cheveux menacent de se faire la malle lol
Evidemment, je continue jusqu'à ....
Mais si quelqu'un passait par là ou idéalement mon cher Gérard ....
En cas, je joins le fichier test,
lionel
 

Pièces jointes

  • isiTel_Lionel Sextant 2023 06 13.xlsm
    27.5 KB · Affichages: 11
Dernière édition:
Solution
J'aime bien toujours avoir 2 copies (hérité de ma maman qui avait tjrs peur de manquer après la guerre, elle remplissait tout de nourriture) :)
Alors utilise cette macro :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1]) Is Nothing Then Exit Sub
Dim fichier1$, chemin$, fichier2$, a$(), n%
fichier1 = ThisWorkbook.Name
If fichier1 Like "* ## ## ##*" Then Exit Sub
ThisWorkbook.Save 'enregistre le fichier
chemin = ThisWorkbook.Path & "\Sauvegarde\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin
fichier2 = Dir(chemin & "*.xlsm")
While fichier2 <> ""
    ReDim Preserve a(n) 'base 0
    a(n) = fichier2
    If n Then Kill chemin & a(n - 1) 'vide le dossier
    n = n + 1
    fichier2 = Dir
Wend...

Phil69970

XLDnaute Barbatruc
Bonjour à tous

Perso je rejoins Vincent au post #2 :
Lionel cela frise la parano et à mon avis ne sert à pas grand chose sinon à rien, voir pire à faire des c...neries
Je m'explique :
1 que la sauvegarde ne se fasse qu'au changement (modification d'une cellule - B1 par exemple),
2 que la sauvegarde se mette dans un dossier qui sera sur le bureau ("sauvegarde" par exemple),
3 (inchangé) pour ne pas encombrer l'ordi de fichiers de ne laisser que les 2 derniers fichiers sauvegardés,
Donc si je te suis et que je suis l'utilisateur du fichier ....

1) Je modifie B1
2) La sauvegarde n° 1 se lance
3)Je m'aperçois que je me suis trompé je modifie plein de chose
4)Et dans la foulée je modifie B1
5)La sauvegarde n° 2 se lance
6)Finalement je re modifie plein de choses et je rechange B1
7)La sauvegarde n° 3 se lance et la sauvegarde n° 1 est supprimé
8)Pas de chance je re modifie de nouveau plein de choses et je re modifie B1
9)La sauvegarde n° 4 se lance et la sauvegarde n° 2 est supprimé

Donc maintenant tu es sans filet puisqu'il n'y a plus de lien avec ce que tu avais au 1)
Pour résumer ta protection avec tes sauvegardes n'est qu'une illusion et peut même être potentiellement pire.....

Ma logique (et celles de grandes entreprises) est de faire on fait une sauvegarde par jour , 1 par semaine et une par mois.
J1 à J31
S1 à S52
M1 à M12

Et j'ajouterais ou sont stockées les sauvegardes et si tu perds ton PC pas de bol !!!!
J1 à J31 sur le site
S1 à S52 sur un autre site et au coffre
M1 à M12 sur 2eme autre site et au coffre

Bonne lecture

@Phil69970
 

job75

XLDnaute Barbatruc
Bonsoir Lionel, le forum,

Tu as bien dit que la sauvegarde doit se faire quand on modifie B1 alors utilise :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1]) Is Nothing Then Exit Sub
Dim fichier1$, chemin$, fichier2$
fichier1 = ThisWorkbook.Name
If fichier1 Like "*######*" Then Exit Sub
ThisWorkbook.Save 'enregistre le fichier
chemin = ThisWorkbook.Path & "\Sauvegarde\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin
fichier2 = Dir(chemin & "*.xlsm")
While fichier2 <> ""
    Kill chemin & fichier2 'vide le dossier
    fichier2 = Dir
Wend
ThisWorkbook.SaveCopyAs chemin & Left(fichier1, Len(fichier1) - 5) & Format(Now, " hhmmss") & ".xlsm" 'sauvegarde
End Sub
A+
 

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bsr Gérard :)
Merci encore d'être là sans jugement....
Il est vrai que ça peut paraître tordu mais cela ne l'est pas.

Je voudrais simplement faire régulièrement et au moment où je le souhaite mes 2 sauvegardes de sécurité et selon ma conception.

Ton code de 2019 est génial. Je voudrais simplement qu'il s'exécute autrement.
OUI la sauvegarde doit se faire quand on modifie B1 car c'est toujours la fin d'une série d'actions suite à appel.

Je vais voir cela.
Merci Gérard
:)
 
Dernière édition:

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Re Bsr Gérard :)
Comme d'habitude, c'est nickel.
Il y a juste 2 choses :
1- le non de la sauvegarde était sous cette forme "isiTel_Lionel Sextant 2023 06 13 18 13 58"
Maintenant ça donne ça "isiTel_Lionel Sextant 2023 06 13 233606"

2 - il ne garde plus les 2 dernières sauvegardes, il remplace par la dernière,

Je vais tenter de voir ça,

Merci Gérard,
:)
 
Dernière édition:

TooFatBoy

XLDnaute Barbatruc
1- le non de la sauvegarde était sous cette forme "isiTel_Lionel Sextant 2023 06 13 18 13 58"
Maintenant ça donne ça "isiTel_Lionel Sextant 2023 06 13 233606"
As-tu regardé le code :
ThisWorkbook.SaveCopyAs chemin & Left(fichier1, Len(fichier1) - 5) & Format(Now, " hhmmss") & ".xlsm" 'sauvegarde



2 - il ne garde plus les 2 dernières sauvegardes, il remplace par la dernière,
As-tu regardé le code :
While fichier2 <> ""
Kill chemin & fichier2
'vide le dossier
fichier2 = Dir
Wend
 

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bjr Fipat :)
Encore merci pour ton fichier.
Désolé de ne pas t'avoir répondu hier.
Ton fichier fonctionne mais il y a quelques soucis
Le plus important est qu'il enregistre une copie mais qu'il ne garde pas le fichier d'origine ouvert.
Le but :
1 - faire une copie en restant sur le fichier d'origine ouvert, donc actif,
2 - garder dans le dossier "sauvegarde" les 2 dernières copies
:)
 

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bjr Fipat :)
Encore merci pour ton fichier.
Désolé de ne pas t'avoir répondu hier.
Ton fichier fonctionne mais il y a quelques soucis
Le plus important est qu'il enregistre une copie mais qu'il ne garde pas le fichier d'origine ouvert.
Le but :
1 - faire une copie en restant sur le fichier d'origine ouvert, donc actif,
2 - garder dans le dossier "sauvegarde" les 2 dernières copies
:)
Bjr à toi :)
Ben OUI : le fichier de Fipat fonctionne, mais :
- il fait la copie mais il l'ouvre et ferme le fichier ouvert au départ.
:)
 

Fipat

XLDnaute Occasionnel
Bonjour,

Change la ligne :
VB:
ThisWorkbook.SaveAs Filename:=Dossier & NomFichier, FileFormat:=xlOpenXMLWorkbookMacroEnabled

Par :
Code:
ThisWorkbook.SaveCopyAs Filename:=Dossier & NomFichier

Il reste dans le dossier sauvegarde le fichier d'origine et les deux sauvegardes.
Avec cette ligne le fichier d'origine reste ouvert.
 

job75

XLDnaute Barbatruc
Bonjour Lionel, le forum,

Il me semble qu'un seul fichier dans le dossier Sauvegarde suffit.

Pour le format il suffit de remplacer " hhmmss" par " hh mm ss"

Et If fichier1 Like "*######*" Then Exit Sub par If fichier1 Like "*## ## ##*" Then Exit Sub

A+
 

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour,

Change la ligne :
VB:
ThisWorkbook.SaveAs Filename:=Dossier & NomFichier, FileFormat:=xlOpenXMLWorkbookMacroEnabled

Par :
Code:
ThisWorkbook.SaveCopyAs Filename:=Dossier & NomFichier

Il reste dans le dossier sauvegarde le fichier d'origine et les deux sauvegardes.
Avec cette ligne le fichier d'origine reste ouvert.
Bjr Fipat :)
Ben .... tout à l'air de fonctionner, y compris la conservation des 2 derniers fichiers sauvegardés :)
Je regarderai mieux quand j'aurai plus de temps mais tout à l'air bon.
:)
 
Dernière édition:

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour Lionel, le forum,

Il me semble qu'un seul fichier dans le dossier Sauvegarde suffit.

Pour le format il suffit de remplacer " hhmmss" par " hh mm ss"

Et If fichier1 Like "*######*" Then Exit Sub par If fichier1 Like "*## ## ##*" Then Exit Sub

A+
Bjr Gérard :)
Merci d'être encore là...
OK, je remplace pour le format.
"Il me semble qu'un seul fichier dans le dossier Sauvegarde suffit."
J'aime bien toujours avoir 2 copies (hérité de ma maman qui avait tjrs peur de manquer après la guerre, elle remplissait tout de nourriture) :)
lol, je devine ta pensé ainsi que celles de nos autres amis ;)
 
Dernière édition:

job75

XLDnaute Barbatruc
J'aime bien toujours avoir 2 copies (hérité de ma maman qui avait tjrs peur de manquer après la guerre, elle remplissait tout de nourriture) :)
Alors utilise cette macro :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B1]) Is Nothing Then Exit Sub
Dim fichier1$, chemin$, fichier2$, a$(), n%
fichier1 = ThisWorkbook.Name
If fichier1 Like "* ## ## ##*" Then Exit Sub
ThisWorkbook.Save 'enregistre le fichier
chemin = ThisWorkbook.Path & "\Sauvegarde\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin
fichier2 = Dir(chemin & "*.xlsm")
While fichier2 <> ""
    ReDim Preserve a(n) 'base 0
    a(n) = fichier2
    If n Then Kill chemin & a(n - 1) 'vide le dossier
    n = n + 1
    fichier2 = Dir
Wend
ThisWorkbook.SaveCopyAs chemin & Left(fichier1, Len(fichier1) - 5) & Format(Now, " hh mm ss") & ".xlsm" 'sauvegarde
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
312 209
Messages
2 086 271
Membres
103 168
dernier inscrit
isidore33