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

[ivan27]

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]

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]

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]

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

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