VBA Excel : Création automatique de dossiers et sous-dossiers

Bonjour à tous,

J’ai besoin de votre aide pour un projet en VBA. Je souhaite créer des dossiers et sous-dossiers de manière hiérarchisée à partir d’un tableau dans l’onglet "Feuil1" d’un fichier Excel.

J’ai déjà un code VBA, mais il pose problème et ne fonctionne pas comme prévu. Quelqu’un pourrait-il m’aider à le corriger ?

Merci d’avance pour votre aide !

Sub creer_dossier()

Dim lstrw As Long
Dim chemin_dossier As String
Dim niveau_dossier As Long
Dim base_chemin_dossier As String

base_chemin_dossier = "C:\Users\toto\Desktop\ExcelDossiers\"

'identifier le fichier et les feuilles
Call load_public_variable

'derniere ligne
lstrw = ws_2.Cells(Rows.Count, 1).End(xlUp).Row

'boucle sur la données
For i = 2 To lstrw

    'Trouver le niveau du dossier
    niveau_dossier = ws_2.Cells(i, 1)

    'Chemin dossier
    chemin_dossier = base_chemin_dossier

    'boucle sur les niveaux à intégrer
    For j = 2 To niveau_dossier + 1

        chemin_dossier = chemin_dossier & ws_2.Cells(i, j) & "\"

        'vérifier l'existance du dossier
        If Dir(chemin_dossier, vbDirectory) <> vbNullString Then
            'dossier existe
        Else
            'créer le dossier
            MkDir (chemin_dossier)
        End If
    Next

Next

End Sub

bonjour nini007,

un essai

Sub creer_dossier()

     Dim Arr, s, i, j, chemin_dossier As String
     Dim base_chemin_dossier As String

     base_chemin_dossier = "C:\Users\toto\Desktop\ExcelDossiers\"
     'base_chemin_dossier = ThisWorkbook.Path & "\"

     'identifier le fichier et les feuilles
     'Call load_public_variable

     Arr = Range("hierarchie_Dossier").Value2     'lire le contenu du TS
     For i = 1 To UBound(Arr)                'boucler les lignes
          s = ""                             'RAZ
          For j = 2 To UBound(Arr, 2)        'boucler les colonnes
               If Len(Arr(i, j)) > 0 Then
                    s = s & "\" & Arr(i, j)  'fusionner subidrectories
               Else
                    Exit For
               End If
          Next

          If Len(s) > 0 Then                 'le chemin n'est pas vide
               chemin_dossier = base_chemin_dossier & Mid(s, 2)     'chemin à vérifier et event. créer
               If Dir(chemin_dossier, vbDirectory) = vbNullString Then Shell "cmd /c md " & Chr(34) & chemin_dossier & Chr(34), 0
               'CreateObject("shell.application").Namespace("G:\").NewFolder "OF\AA1\BB2"
          End If
     Next

End Sub

Bonsoir à tous ,

Ne disposant pas de tous les éléments (notamment entre autres la procédure load_public_variable, la variable ws_2, ...), j'ai donc adapté...

• Le code a été réécrit à ma façon (notamment l'algorithme)
• Le répertoire de base est C:\@Bidon (il est créé si inexistant)
• le code est commenté
• Cliquez sur la forme en bleu "Créer une arborescence de répertoires"
• notez la présence d'une petite tempo quand on crée un répertoire. Sans cette tempo, j'ai quelquefois du mal à supprimer les répertoires créés parce que Windows m'indique que je n'ai pas les droits (c'est aussi bizarre qu'étrange) mais avec la tempo ça ne se produit plus .

Le code dans le module de la feuille "Feuil1" :

Sub creer_dossier()
Dim base_chemin_dossier As String, chemin_dossier As String, ws_2 As Worksheet
Dim t, lstrw As Long, i As Long, j As Long, k As Long, m As Long

   Set ws_2 = Worksheets("Feuil1")        ' la feuille concernée
   base_chemin_dossier = "C:\@Bidon"      ' le répertoire de base <sans antislash à la fin>. Il sera créé si inexistant
   If Dir(base_chemin_dossier, vbDirectory) = vbNullString Then MkDir base_chemin_dossier

   If ws_2.FilterMode Then ws_2.ShowAllData           ' si filtrage alors on affiche tout
   lstrw = ws_2.Cells(Rows.Count, 1).End(xlUp).Row    ' dernière ligne
   t = ws_2.ListObjects(1).DataBodyRange              ' lecture des valeurs du premier tableau structuré de la feuille ws_2
                                                      ' vers le tableau en mémoitre t
   For k = 1 To UBound(t, 2) - 1    ' boucle sur les niveaux de 1 à nombre de colonnes de t - 1
      For i = 1 To UBound(t)        ' boucle sur les lignes de t
         If t(i, 1) = k Then        ' si le niveau de la ligne est égal à k alors
            ' construction du chemin
            chemin_dossier = base_chemin_dossier      ' on initialise le chemin du répertoire à créer avec le répertoire de base
            ' on ajoute les répertoires des colonnes 2 à k+1 - du niveau 1 (colonne 2) au niveau k (colonne k+1)
            For j = 2 To k + 1      ' on ajoute les chemins des niveaux 1 à k (ça commence en colonne 2 jusqu'à colonne k+1)
               chemin_dossier = chemin_dossier & "\" & t(i, j)    ' on ajoute les chemins des colonnes 2 à k+1 (niveau 1 à k)
            Next j
            If Dir(chemin_dossier, vbDirectory) = vbNullString Then  ' si le chemin n'existe pas
               MkDir (chemin_dossier)                                ' alors on le crée
               For m = 1 To 100: DoEvents: Next                      ' petite tempo
            End If
         End If
      Next i
   Next k
   MsgBox "Fin de la création de l'arborescence.", vbInformation
End Sub

Bonjour à vous deux,

Merci pour votre message et votre aide.

J’ai testé les deux codes, et ils fonctionnent parfaitement. J’ai effectué quelques essais, et tout est en ordre.

Dans les prochains mois, je devrai créer une arborescence avec des sous-dossiers sur plus de trois niveaux. Je vous tiendrai informés et me permettrai de revenir vers vous en cas de problème.

Merci encore et à bientôt !