Enregistrement à la fermeture dans un dossier suivant la date actuelle

Bonjour,

J'aimerais savoir si cela est possible qu'à la fermeture d'un fichier Excel, celui-ci s'enregistre automatiquement dans un fichier contenant son nom et sa date ainsi qu'un nombre par ordre d'enregistrement tout ça dans le dossier du mois, je m'explique mes dossiers seront Rapport>Année>Mois et dans ce dossier mois j'aurais les fichiers XX AAAAMMJJ mais j'aurais plusieurs fichier par jour, et il faut donc que d'une part le fichier s'enregistre dans le bon dossier année ainsi que mois et qu'en plus le fichier contienne dans son nom la date et le numéro du fichier du jour (ex: test 20210214 1 puis test 20210214 2, etc.. ) puis le lendemain (test 20210215 1, test 20210215 2, etc.. )

Je vous remercie d'avance pour votre aide, et vous souhaite un bon dimanche.

SToXiT

Bonjour,

Voici un essai sachant que je recommande d'utiliser la date et l'heure ce qui ajoute une précision supplémentaire et aère beaucoup le code. J'ai laissé 2, 3 commentaires pour les détails à contrôler. Je pourrais mieux expliquer si besoin :

'MODULE THISWORKBOOK
private sub workbook_beforeclose(cancel as boolean)
me.save
call sauvegarde(me.name)
end sub

'MODULE STANDARD
sub sauvegarde(NomClasseur$)

dim spath$

dossier = "C:\DOSSIERS\Rapport\" '<<<< ADAPTER CHEMIN
spath = dossier & replace(Format(Date, "YYYY-MM"), "-", "\") & "\" '<<<< dossiers mois supposés "01", "02", ..., "12"
if not creerdossiers(spath) then
    msgbox "Une erreur s'est produite ! Vérifiez l'accès au lecteur et contrôlez le chemin renseigné...", 16, "Opération annulée"
    exit sub
end if
chemin = spath & NomClasseur & " " & format(Now, "YYYYMMDD HHMMSS") & ".xlsm" '<<<<<<<<< OPTION HORODATAGE
'fichier = dir(spath & NomClasseur & " " & format(Date, "YYYYMMDD") & "*.xls*") 'SINON OPTION NUMERO (lignes désactivées)
'while fichier <> ""
'    n = n + 1
'    fichier = dir
'wend
'chemin = spath & NomClasseur & " " & format(Date, "YYYYMMDD") & " " & n + 1 & ".xlsm"
thisworkbook.savecopyas chemin

end sub

'MODULE STANDARD
function creerdossiers(chemin$) as boolean
t = split(chemin, "\")
if ubound(t) > 0 then rep = t(0) else exit function
for i = 1 to ubound(t)
    rep = rep & "\" & t(i)
    on error resume next
    if dir(rep, vbdirectory) = "" then mkdir rep
    if err.number > 0 then err.clear: exit function
next i
creerdossiers = true
end function

Cdlt,

Boujour l'équipe.

Autre proposition, mais je déconseille vivement les sauvegardes automatiques. 9a peut conduire à des catas. Dans l'exemple ci-dessous, si le dossier de sauvegarde ([dossier courant\annee\mois\) n'existe pas, il le crée.

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim dossier As String, fichier As String
    Dim mot() As String, newName As String
    Dim annee As String, mois As String
    Dim chemin As String, i As Integer

    chemin = Application.ActiveWorkbook.Path & "\"

    annee = Year(Date)
    mois = Right("00" & Month(Date), 2)

    ' Si le dossier de l'année n'existe pas, on le crée
    dossier = chemin & annee
    If Dir(dossier, vbDirectory) = "" Then MkDir dossier
    ' Si le dossier du mois n'existe pas, on le crée
    dossier = dossier & "\" & mois
    If Dir(dossier, vbDirectory) = "" Then MkDir dossier
    dossier = dossier & "\"

    ' On compte le nombre de fichiers dans le dossier du mois
    fichier = Dir(dossier & "*")
    Do While fichier <> ""
        i = i + 1
        fichier = Dir()
    Loop

    mot = Split(ThisWorkbook.Name, ".")
    newName = dossier & mot(0) & annee & mois & jour & Right("0000" & Trim(Str(i + 1)), 4) & "." & mot(1)
    ActiveWorkbook.SaveAs Filename:=newName
End Sub

Bonsoir à vous deux,

Tout d'abords merci, 3GB J'ai essayer ta solution qui marche très bien merci à toi et Optimix mer i à toi aussi cela fonctionne aussi

Super ! Merci pour ce retour !

Et n'oubliez pas, l'horodatage, c'est mieux

Oui j'ai opté pour cette solution, tu as raison c'est plus clair et plus simple de resituer le fichier.

Très belle ta fonction creerdossiers() 3GB, je la mets dans mes outils.

Merci pour le partage.

Merci Optimix !

D'ailleurs, je viens d'y faire une toute petite modification suite à ton commentaire. If ubount(t) > 0

Mais il y a sûrement moyen de l'améliorer...

A bientôt,

Effectivement 0 et mieux que -1. Mais c'est la compacité du code que je trouve superbe quand on connaît la lourdeur pour créer des sous...sous...sous-dossiers sous VB.

Oui, c'est clair... Mais sinon, il y a le filesystemobject quand vraiment ça se complique, c'est plus simple et plus complet ! Parce la fonction dir est sympa mais on est vite limité en cas d'imbrications étant donné que le résultat ne retient que la dernière valeur entrée en argument

Encore une petite question ton code m'enregistre le classeur au chemin indiquer mais aussi sur le classeur actuel, serait-il possible de ne pas enregistrer sur le classeur actuel

Bonjour sToXit,

Comme l'a dit Optimix, il faut faire attention à ce genre de copies... Il est possible de remplacer la ligne savecopyas par saveas. Mais dans ce cas, la version d'origine est écrasée donc il faut être vigilant et prier pour ne pas rencontrer de problèmes.

Sinon, il est possible de laisser cette ligne et d'enlever la ligne me.save dans la macro beforeclose. Ainsi, on enregistre pas les modifications dans le classeur source mais on crée une copie avec ces modifications.

Je serais plutôt favorable à cette seconde option qui permet de garder un classeur modèle.

'OPTION 1
'MODULE STANDARD
sub sauvegarde(NomClasseur$)
'CODE------
thisworkbook.saveas chemin
end sub

'OPTION 2
'MODULE THISWORKBOOK
private sub workbook_beforeclose(cancel as boolean)
call sauvegarde(me.name)
end sub

Cdlt,

Merci 3GB effectivement il me faudrait garder le fichier d'origine.

Cdlt SToXiT