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

arthour973

XLDnaute Barbatruc
Supporter XLD
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 = valeur A1

J'ai relevé le code sur : https://forum.excel-pratique.com/viewtopic.php?t=18819 que je remercie au passage

Le code enregistre dans "mes documents"
J'ai besoin que l'enregistrement se fasse sur le bureau de l'ordinateur (ou autre nom du bureau, quel que soit l'ordinateur)

D'autre part et si possible LOL
en remplacement des codes : Range("b1").Value = Range("b1").Value + 1 et [a1] = "=""enregistrement""&RC[1]"
qui m'obligent à occuper 2 cellules (a1 et b1) de ma feuille … est-il possible d'écrire un code qui enregistre directement sous le nom du classeur actif +1
J'ai cherché et fait des tests sans meilleure réussite.

Comme d'hab, je fais appel à votre expertise pour une solution qui m'arrangerait bien :)
Je joins le fichier test paramétré pour tests toutes les 10 secondes.

Un grand merci une fois de plus à toutes et à tous,
Amicalement,
Lionel,
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Bonjour Lionel,

Les codes que tu indiques sont inutilement compliqués, vois le fichier joint avec :

- dans le module standard :
VB:
Public t# 'mémorise la variable

Sub Enregistrer()
ThisWorkbook.SaveAs ThisWorkbook.Path & "\enregistrement" & Val(Mid(ThisWorkbook.Name, 15)) + 1
On Error Resume Next
Application.OnTime t, "Enregistrer", , False
t = Now + 5 / 1440 'délai de 5 minutes
Application.OnTime t, "Enregistrer"
End Sub
- dans ThisWorkbook :
VB:
Private Sub Workbook_Open()
t = Now + 5 / 1440 'délai de 5 minutes
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
A+
 

Fichiers joints

laurent950

XLDnaute Impliqué
Bonjour lionel et Job75,

La macro 1 peux être aussi changer ainsi
VB:
Sub Macro1()
    'MsgBox Split(ThisWorkbook.Name, ".")(0)
    For i = 1 To Len(Split(ThisWorkbook.Name, ".")(0))
        c = Mid(Split(ThisWorkbook.Name, ".")(0), i, 1)
        If c >= "0" And c <= "9" Or c = "." Then Temp = Temp & c
    Next i
    NumChaine = Val(Temp)
    NumChaine = NumChaine + 1
    Sauvgarde = Replace(ThisWorkbook.Name, Val(Temp), NumChaine)
    'ActiveWorkbook.SaveAs Filename:=[a1].Value
    ActiveWorkbook.SaveAs Filename:=Sauvgarde
    'Range("b1").Value = Range("b1").Value + 1
    '[a1] = "=""enregistrement""&RC[1]"
End Sub
 

arthour973

XLDnaute Barbatruc
Supporter XLD
Re-Gérard,
Evidemment ça marche :)
Un gros MERCI de plus

J'aurais une dernière question sur ce sujet (LOL on ne fera pas 70 posts sur celui-là :))
Je vais revenir pour voir si réponse possible.
Lionel,
 

arthour973

XLDnaute Barbatruc
Supporter XLD
Re-Gérard,

Nickel de chez nickel :)

Je reviens pour dernière question :)
Sur le bureau des ordinateurs de mes commerciales, en enregistrant toutes les 5 minutes, il va y avoir une flopée de classeurs qui, mélangés à ce qui est déjà sur leurs bureaux, va mettre pour elles la pagaille et va leur prendre du temps pour les supprimer (pour ne garder que le dernier) avec le risque de supprimer d'autres fichiers ou dossiers importants pour elles.

Serait-il possible par code, dans le fichier ou autre ... de ne garder que les 5 derniers ?
OUI, je sais ... pour les miracles je vais m'adresser vers le ciel ... mais LOL, n'y suis-je pas ? :)
 

arthour973

XLDnaute Barbatruc
Supporter XLD
Effectivement, je comprends la question :)

En cas de plantage excel ou ordi et éventuelle perte du fichier ouvert ...
Ces enregistrements chaque 5 minutes sont la certitude d'avoir le travail fait enregistré dans un fichier "distinct" chaque 5 minutes avant.

Mais des dizaines de classeurs : ça va mettre la pagaille sur leurs bureaux.
Et le dernier classeur enregistré est suffisant puisqu'il contient le travail fait. :)
 
Dernière édition:

job75

XLDnaute Barbatruc
Je dirais même que ne garder que les 2/3 derniers fichiers enregistrés serait suffisant :)
En ajoutant cette instruction dans la macro Enregistrer on conserve seulement les 3 derniers fichiers :
VB:
Kill ThisWorkbook.Path & "\enregistrement" & Val(Mid(ThisWorkbook.Name, 15)) - 3 & ".xlsm"
 

Fichiers joints

arthour973

XLDnaute Barbatruc
Supporter XLD
Bonjour Gérard, le forum,
Je confirme que ton code fonctionne super bien mais il y a une chose que je ne comprends pas :

dans le code le nom du classeur est "\enregistrement"
ThisWorkbook.SaveAs ThisWorkbook.Path & "\enregistrement" & Val(Mid(ThisWorkbook.Name, 15)) + 1
et
Kill ThisWorkbook.Path & "\enregistrement" & Val(Mid(ThisWorkbook.Name, 15)) - 3 & ".xlsm"

Je voudrais modifier le nom (1 nom classeur par Commerciale), par exemple "\Charlotte_isitelImmobProspection" soit :
ThisWorkbook.SaveAs ThisWorkbook.Path & "\Charlotte_isitelImmobProspection" & Val(Mid(ThisWorkbook.Name, 15)) + 1
et
Kill ThisWorkbook.Path & "\Charlotte_isitelImmobProspection" & Val(Mid(ThisWorkbook.Name, 15)) - 3 & ".xlsm"

et là, ça fonctionne plouf plus .... ai-je oublié de modifier qqchose ?

après réflexion, je pense que c'est la mémorisation. Je vais voir :)

Bon dimanche :)
lionel,
 
Dernière édition:

Calvus

XLDnaute Accro
Bonsoir Lionel, Gérard, laurent 950, le forum,

Il faut que tu remplaces comme ceci :

VB:
Sub Enregistrer()
ThisWorkbook.SaveAs ThisWorkbook.Path & "\Charlotte_isitelImmobProspection" & Val(Mid(ThisWorkbook.Name, 33)) + 1
On Error Resume Next
Application.OnTime t, "Enregistrer", , False
t = Now + 5 / 1440 'délai de 5 minutes
Application.OnTime t, "Enregistrer"
Kill ThisWorkbook.Path & "\Charlotte_isitelImmobProspection" & Val(Mid(ThisWorkbook.Name, 33)) - 3 & ".xlsm"
End Sub
Ici, Val(Mid(ThisWorkbook.Name, 33)), le chiffre doit correspondre au nombre de caractères du nom de ton classeur.

Voilà.

A+
 

laurent950

XLDnaute Impliqué
Bonsoir Lionel, Gérard, Clavus, le forum,

découpage :
Nom du fichier sans la valeur numérique et la valeur numérique
pour l’enregistrement et l'incrémentation

VB:
Sub test()
' Trouve le non du fichier (complet)
    MsgBox ThisWorkbook.Name

' Trouver l'extension du fichier
    MsgBox Split(ThisWorkbook.Name, ".")(1)

' Trouve le non du fichier (sans l'extension)
    MsgBox Split(ThisWorkbook.Name, ".")(0)

' Trouve une valeur numérique (dans le nom du fichier "sans l'extension")
Dim i As Integer
Dim c As String
Dim temp As String
Dim NumChaine As Integer

    For i = 1 To Len(Split(ThisWorkbook.Name, ".")(0))
        c = Mid(Split(ThisWorkbook.Name, ".")(0), i, 1)
        If c >= "0" And c <= "9" Or c = "." Then temp = temp & c
    Next i
    NumChaine = Val(temp)
    MsgBox NumChaine

' Trouve le non du fichier sans la valeur numérique (suppression de la valeur numérique dans le nom du fichier "sans l'extension")
MsgBox Left(Split(ThisWorkbook.Name, ".")(0), Len(Split(ThisWorkbook.Name, ".")(0)) - Len(NumChaine))

' Incremetation du Numéréro du fichier + 1 (Nom du fichier + l'ancienne valeur numérique incrémenté de +1 chiffre)
Dim NouveauNomFichier As String
NouveauNomFichier = Left(Split(ThisWorkbook.Name, ".")(0), Len(Split(ThisWorkbook.Name, ".")(0)) - Len(NumChaine)) & NumChaine + 1
MsgBox NouveauNomFichier

' soit en remplacement par une variable (du nombre de caractère du fichier sans sa valeur numérique)
' ThisWorkbook.SaveAs ThisWorkbook.Path & "\enregistrement" & Val(Mid(ThisWorkbook.Name, 15)) + 1
' Entre crochet ' ThisWorkbook.SaveAs ThisWorkbook.Path & ["\enregistrement" & Val(Mid(ThisWorkbook.Name, 15)) + 1]
' par
' ' Entre crochet ' ThisWorkbook.SaveAs ThisWorkbook.Path & NouveauNomFichier

' ici
MsgBox Val(Mid(ThisWorkbook.Name, 15)) - 3
MsgBox Val(Mid(ThisWorkbook.Name, Len(NouveauNomFichier) - 1)) - 3
' Kill ThisWorkbook.Path & ["\enregistrement" & Val(Mid(ThisWorkbook.Name, 15))] - 3 & ".xlsm"
' Kill ThisWorkbook.Path & NouveauNomFichier - 3 & ".xlsm"
End Sub
cdt
 
Dernière édition:

arthour973

XLDnaute Barbatruc
Supporter XLD
Bonjour Gérard, Laurent950, Clavus, le forum,
@Gérard,

J'étudie la meilleure façon de renommer le classeur pour visualisation par mes commerciales.

C'est pourquoi j'ai préféré un affichage du jour, heure, minutes et secondes au bout du nom.
Ce qui devrait donner : enregistrement_14-07-19_15-41-45

Mais j'ai 2 soucis :
1 - Il renomme avec un "0" : enregistrement0_14-07-19_15-41-45 que je n'arrive pas à enlever,
code tel que je l'ai modifié :
ThisWorkbook.SaveAs ThisWorkbook.Path & "\enregistrement" & Val(Mid(ThisWorkbook.Name, 14)) & "_" & Format(Date, "dd-mm-yy") & "_" & Format(Time, "hh-mm-ss")

2 - je n'arrive pas à trouver comment coder pour qu'il ne garde que 2 fichiers renommés et sauvegardés :
code : Kill ThisWorkbook.Path & "\enregistrement" & Val(Mid(ThisWorkbook.Name, 14)) - ??? & ".xlsm"

si pas possible, tant pis, je mettrait en place le code nom+1.
Je pense que c'est la dernière fois que je reviens sur le code LOL :)

Intenses remerciements :)
lionel,
 

Discussions similaires


Haut Bas