Microsoft 365 VBA Création dossier + sous dossier + enregistrer le fichier dans le dossier

[raf26]

Bonjour à vous,

Après avoir pas mal cherché et essayé d'adapter différentes solutions, je rame complètement sur une macro qui me permettrait de :

Créer un dossier (nommé avec la valeur d'une cellule) sur le bureau
Créer dans ce dossier un sous dossier (également nommé avec la valeur d'une cellule)
Enregistrer le fichier (également nommé avec la valeur d'une cellule) dans le dossier créé (le sous dossier reste vide).

Je vous remercie par avance de votre contribution.

Bonne journée

 

[raf26]

Bonjour @patricktoulon

Merci j’ai réussi à adapter avec les noms de fichiers aux miens cela est parfait.

Par contre le fichier Excel et le fichier collé par la macro, les 2 sont positionnés dans le sous dossier créé.

Comment faire pour que ces 2 fichiers soient dans le dossier principal créé et non pas dans le sous dossier ?

Voici l’arborescence que je souhaite

Dossier

Fichier Excel qui contient cette lacro
Fichier copié et renommer par la macro

Sous dossier (vide)


Cordialement

 

[patricktoulon]

re

Sub TESTONS()
    'Variables
    Dim maitre$, Nom$, AllFolders As Variant, F1$, F2$, PdfPath$
    'Identifier le chemin par défaut du bureau
    maitre = CreateObject("WScript.Shell").specialFolders("Desktop")

    'collection des noms de dossier dans un array(pas de limite d'arborescence)
    AllFolders = Array(maitre, [H9], [H10])

    'compilation dans la variable "F" dans une boucle sur l'array(Allfolders)
    For i = 0 To UBound(AllFolders)
       If i <= 1 Then
       F1 = F1 & AllFolders(i) & "\"
         If Dir(F1, vbDirectory) = vbNullString Then MkDir F1 'Si le dossier n'existe pas, on le crée
   F2 = F1
   Else
       F2 = F2 & AllFolders(i)
            If Dir(F2, vbDirectory) = vbNullString Then MkDir F2 'Si le dossier n'existe pas, on le crée
   End If
   Next

    'Nom du fichier
    Nom = F1 & [H11]

    'Identifier le chemin du pdf
    PdfPath = F & "Essai_" & [H11] & ".pdf"

    'Enregistrement du fichier
    ThisWorkbook.SaveAs Filename:=Nom, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

    Dim Origin$
    Origin = "C:\documents\essai.pdf"
    Nom = Mid(Origin, InStrRev(Origin, "\") + 1)
    FileCopy Origin, F1 & "Essai_" & Nom

    MsgBox "Votre fichier a été enregistré avec succès."
End Sub