Microsoft 365 Choix du répertoire d'enregistrement en fonction du nom du fichier

ivan27 · 27 Février 2023

Bonjour à tous,

Mon outil génère des fichiers et les nomme avec un préfixe toujours identique suivi d'une date au format dd-mm-yyyy et avec l'extension .xlsm.

Exemple de fichier en pièce jointe. AAA-BB55-24-02-2023.xlsm
Préfixe : AAA-BB55-
Date : 24-02-2023

J'ai un répertoire principal c:\Temp\MesFichiers

Est-il possible de sauvegarder mes fichiers vers le répertoire principal, dans des sous-dossier année / mois et de créer l'arborescence si elle n'existe pas ?
Plus précisément, je demande en VBA l'enregistrement du fichier AAA-BB55-24-02-2023.xlsm dans le répertoire c:\Temp\MesFichiers et les fichiers doivent être automatiquement ventilés vers une arborescence \année\mois. Si l'année 2023 n'existe pas il faut créer un sous répertoire 2023 et/ou si le mois 02 n'existe pas dans le répertoire 2023, il faut aussi créer ce sous-répertoire enregistrer le fichier à l'intérieur.

Merci d'avance pour votre aide.

Ivan

sousou · 27 Février 2023

bonjour
tu peux t'inspirer de ce code, qui va créer les répertoires inexistant
a adapter à ta configuration.
Je termine en affichant le nom du fichier qui pourrait être enregistrer dans ce dossier
ici la racine est c:

Public Const base = "c:/"

Sub nomdossier()

an = InputBox("année")
mois = InputBox("mois")

Set fso = CreateObject("scripting.filesystemobject")
If fso.folderexists(base & an) Then
rep = an
If fso.folderexists(base & an & "/" & mois) Then
fichier = base & "/" & an & "/" & mois & "/" & ThisWorkbook.Name

Else
fso.createfolder (base & an & "/" & mois)
fichier = base & "/" & an & "/" & mois & "/" & ThisWorkbook.Name

End If

Else
fso.createfolder (base & an)
fso.createfolder (base & an & "/" & mois)
fichier = base & "/" & an & "/" & mois & "/" & ThisWorkbook.Name

End If
MsgBox fichier
End Sub

cp4 · 28 Février 2023

Bonjour @sousou , @ivan27 ,
@sousou : Il n'est pas aisé de lire ton code. Merci de l'éditer en utilisant l'outil dédié </>(voir démo)
Bonne journée.

ivan27 · 28 Février 2023

Bonjour à tous,
Merci sousous pour ta proposition.
J'ai pu adapter ton code. Les quelques tests effectués fonctionnent parfaitement.
A bientôt

VB:

Sub nomdossier()

x = ActiveWorkbook.Name 'nom du classeur actif
an = Mid(x, 17, 4)      'extraction de l'année dans le nom de fichier
mois = Mid(x, 14, 2)    'extration du mois dans le nom de fichier

Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(base & an) Then                     'On vérifie si le répertoire année existe
    rep = an
    If FSO.FolderExists(base & an & "/" & mois) Then    'On vérifie si le répertoire mois existe
        fichier = base & "/" & an & "/" & mois & "/" & ThisWorkbook.Name
    Else
        FSO.CreateFolder (base & an & "/" & mois)
        fichier = base & "/" & an & "/" & mois & "/" & ThisWorkbook.Name
    End If
Else
    FSO.CreateFolder (base & an)                        'On crée le répertoire année s'il n'existe pas
    FSO.CreateFolder (base & an & "\" & mois)           'On crée le répertoire mois s'il n'existe pas
End If
    chemin = base & an & "\" & mois & "\"               'Chemin d'enregistrement
    ActiveWorkbook.SaveAs chemin & ActiveWorkbook.Name  'Enregistrement du fichier
    ActiveWorkbook.Close SaveChanges:=False
End Sub

Microsoft 365 Choix du répertoire d'enregistrement en fonction du nom du fichier

ivan27

XLDnaute Occasionnel

Pièces jointes

sousou

XLDnaute Barbatruc

cp4

XLDnaute Barbatruc

ivan27

XLDnaute Occasionnel

Discussions similaires