Création arborescence Dossier et plusieurs sous-dossiers

Bonjour,

Je souhaite créer plusieurs dossiers et sous-dossiers dans mon explorateur windows.

J'ai utilisé le fichier ci-joint avec macro mais la création des dossiers s'arrête au "3.2.3. Notes de service", ligne 51.

Je ne sais pas ce qu'il faut modifier.

D'avance, merci pour votre aide !

Cordialement

Bonjour

Si je fais un Debug.Print au lieu d'un MkDir

Debug.Print .[D4] & "\" & arbo

Voilà ce que ça me donne

C:\Users\MORICE\Desktop\Création arborescence RH\\1. SERVICE RH

Il y a donc déjà un "\" en trop

Ensuite en ligne 52 vous avez "3.2.4 GIM/UIMM"

Ce qui donne

C:\Users\MORICE\Desktop\Création arborescence RH\\3. PILOTAGE RH\3.2 Juridique\3.2.4 GIM/UIMM

Windows n'en veut pas

Voici une possibilité d'y remédier

Sub Creation_Arborescence()
  Dim sh As Worksheet
  Dim Lig As Long, j As Long, Col As Long
  Dim tbs As Variant
  Dim Arbo As String, CarInterdit() As String, sTmp As String
  Dim Ind As Integer
  ' Tableau des caractères interdit
  CarInterdit = Split("<,>,:,/,\,|,?,*", ",")
  ' Définir la feuille
  Set sh = ActiveSheet
  With sh
    If .[D4] = "" Then MsgBox ("le dossier de niveau 0 doit être renseigné"): Exit Sub
    For Lig = .[D1].Column To .[S1].Column Step 1
      derln = Application.Max(derln, .Cells(Rows.Count, Lig).End(xlUp).Row)
    Next Lig
    For Lig = 5 To derln
      For Col = 19 To 5 Step -1
        If .Cells(Lig, Col) <> "" Then
            tbs = Split(Arbo, "\")
            Arbo = ""
            For j = LBound(tbs) + 1 To Col - 5
              Arbo = Arbo & "\" & tbs(j)
            Next j
            ' Récupérer le texte en temporaire
            sTmp = .Cells(Lig, Col)
            ' Vérifier les caractères interdit
            For Ind = 0 To UBound(CarInterdit)
              If InStr(1, sTmp, CarInterdit(Ind), vbTextCompare) > 0 Then
                sTmp = Replace(sTmp, CarInterdit(Ind), "_")
              End If
            Next Ind
            ' Ne pas oublier le guillemet
            If InStr(1, sTmp, Chr(34)) > 0 Then sTmp = Replace(sTmp, Chr(34), "'")
            ' Créer l'arborescence
            Arbo = Arbo & "\" & sTmp
            Exit For
          End If
      Next Col
      If Dir(.[D4] & "\" & Arbo, vbDirectory) = "" Then MkDir .[D4] & Arbo 'création du sous-dossier
    Next Lig
  End With
End Sub

A+

Bonjour Bruno M45 !

Merci pour votre aide.

J'ai modifié, mais maintenant ça s'arrête à la ligne 86 "4.1 Communication RH". Je ne m'y connais pas du tout en Macro et me suis servie d'une base donc incapable de savoir quoi et où modifier...

Cordialement

Bonsoir,

Sachez que je ne vais pas corriger toutes vos erreurs

Voilà pourquoi (pas d'espace à la fin d'un nom de dossier)

Bonne chance