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

[Usine à gaz]

Bonjour à toutes et à tous

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

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

excel-downloads.com

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.

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

 

[Usine à gaz]

Alors utilise cette macro :

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