Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

vgendron

XLDnaute Barbatruc
Bonjour

Je trouve que tu te lances dans des trucs qui ne servent pas à grand chose...
sur un aure post: récuperer un fichier de récupération==>si il y a eu fichier de récup, c'est qu'il y a eu plantage suite à une fausse manip de l'utilisateur (=1ere erreur)
si en PLUS, le fichier de récup est perdu par erreur.. (2eme erreur) bah. à un moment, il faut que l'utilisateur fasse attention à ce qu'il fait... et la perte des données = sanction
quand il en aura marre.. il fera attention: c'est comme quand on supprime un fichier.. il va dans la corbeille. si tu vides la corbeille. et bah. y a un moment faut que ca s'arrete.. tu as déjà eu ta chance de retablir le fichier..

la dans ce post.. comme tu as une confiance incroyable en tes collaborateurs.. tu veux forcer un enregistrement toutes les 30s..
et donc.. toutes les 30s, ils vont voir un rallentissement de leur excel qui ne répondra plus à leurs actions (donc. GROS risque de plantage)....
si en plus, tu te contentais d'enregistrer.. non. la tu veux aussi supprimer des fichiers anciens..
à vouloir "protéger", je pense que tu encombres les processus plus qu'autre chose..


maintenant..
1) lancer quelque chose au changment d'une cellule
depuis le temps, tu devrais savoir qu'il faut utiliser l'évènement change de la feuille et faire un test si intersec(B1, target)....
2) sauvegarde: workbook.saveas (l'enregistreur de macro va te donner la syntaxe à utiliser)
 

TooFatBoy

XLDnaute Barbatruc
Bonjour,

si il y a eu fichier de récup, c'est qu'il y a eu plantage suite à une fausse manip de l'utilisateur
Vu les fichiers utilisés, le fait que le plantage vienne d'une fausse manip de l'utilisateur n'est pas la cause que j'envisagerai en premier...

Sinon, tu as bien sûr raison sur tout le reste : bretelles + ceinture, ce n'est pas forcément mieux.
 

Fipat

XLDnaute Occasionnel
Bonjour,

Ce code peut convenir ?

 

Pièces jointes

  • isiTel_Lionel Sextant 2023 06 13 17 50 27.xlsm
    30.4 KB · Affichages: 9

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…