Sub Creation_Repertoires()
Dim Lr As Long
Dim Cel As Range
' dernière cellule non vide de la colonne C
Lr = Cells(Rows.Count, "C").End(xlUp).Row
' pour chaque cellule dans la colonne C à partir de la ligne 11 ( jusqu'à la ligne Lr )
For Each Cel In Range("C11:C" & Lr)
' on indique les arborescences à créer
Create_Rep [C6] & "\" & [D4] & "\" & Cel
Create_Rep [C7] & "\" & [D4] & "\" & Cel
Next
MsgBox "Fini"
End Sub
Sub Create_Rep(Arbo As String)
Dim FSO As Object
Dim Chemin As String
Dim Folders, Folder
Set FSO = CreateObject("Scripting.FileSystemObject")
' On décompose l'arborescence en un tableau de sous-dossiers
Folders = Split(Arbo, "\")
' Pour chaque sous-dossier dans la table
For Each Folder In Folders
' on reconstruit au fur et à mesure l'arborescence des sous-dossiers à créer
Chemin = IIf(Chemin = "", "", Chemin & "\" ) & Trim(Folder)
' s'il n'existe pas, on le crée
If Not FSO.FolderExists(Chemin) Then FSO.CreateFolder (Chemin)
Next
Set FSO = Nothing
End Sub