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

Usine à gaz

XLDnaute Barbatruc
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...

Usine à gaz

XLDnaute Barbatruc
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
Bjr Gérard :)
Grand merci encore : tout nickel
:)
 

Discussions similaires

Statistiques des forums

Discussions
313 283
Messages
2 096 809
Membres
106 751
dernier inscrit
Souleymani