XL 2016 Creation de dossier et sous dossier depuis Excel

'efface ce qui est en rouge
Sub efface()
    Dim cel As Range
    With ActiveSheet.UsedRange
        For Each cel In .Cells
            If cel.Font.Color <> vbBlack Then cel.Value = ""
        Next
        .Font.Color = vbBlack
    End With
End Sub


Sub Comble_les_blancs()
    Dim lig&, c&, Nom$
    With ActiveSheet.UsedRange
        'le premier dossier  en colonne 1
        For i = 3 To .Cells(.Cells.Count).Row
            .Cells(i, 1) = .Cells(2, 1)
            .Cells(i, 1).Font.Color = vbRed
        Next
        'les dossier manquant dans le tableau
        For c = 2 To 6
            Nom = ""
            For lig = 2 To .Cells(.Cells.Count).Row
                If .Cells(lig, c) <> "" Then
                    Nom = .Cells(lig, c)
                Else
                    If .Cells(lig, c - 1) = Cells(lig - 1, c - 1) And .Cells(lig, c - 1) <> "" Then
                        .Cells(lig, c) = Nom
                        .Cells(lig, c).Font.Color = vbRed
                    End If
                End If
            Next
        Next
    End With
End Sub

'maintenant on peut lire ligne par ligne  et construire les dossiers et sous dossiers
'dans une boucle avec un test dir a chaque fois
Sub createfolder()
    Dim Tablo, i&, c&, chemin$
    Tablo = ActiveSheet.UsedRange.Value
    For i = 2 To UBound(Tablo)
        chemin = ThisWorkbook.Path 'adapter la racine ICI
        For c = 1 To UBound(Tablo, 2)
            If Tablo(i, c) <> "" Then chemin = chemin & "\" & Tablo(i, c)
            'If Dir(chemin, vbDirectory) = "" Then MkDir chemin     ' ligne à debloquer
        Next
        Debug.Print chemin
    Next
End Sub

'maintenant on peut lire ligne par ligne  et construire les dossiers et sous dossiers
'dans une boucle avec un test dir a chaque fois
Sub createfolder()
    Dim Tablo, i&, c&, chemin$
    Tablo = ActiveSheet.UsedRange.Value
    For i = 2 To UBound(Tablo)
        chemin = ThisWorkbook.Path 'adapter la racine ICI
        For c = 1 To UBound(Tablo, 2)
            If Tablo(i, c) <> "" Then
                chemin = chemin & "\" & Tablo(i, c)
               chemin = Replace(chemin, "/", "_")
                If Dir(chemin, vbDirectory) = "" Then MkDir chemin ' ligne à debloquer
            End If
        Next
        Debug.Print chemin
    Next
End Sub

'******************************************
'fonction liste dossier  en recursif pour lister les  dossiers et sous dossiers d'un dossier ou disque racine
'auteur :patricktoulon
'date :03/07/2018
'avec un object collection pour relancer la récursivité avec la compilation des subfolder
'****************************************************************

Const maitre = "C:\Users\patricktoulon\Desktop\toto" 'adapter le chemin

Sub clearAll()
Cells.ClearContents
End Sub

Function FSO_List_DOSSIER(ByVal Folder As Variant) As Variant
    Static tbl() As String: Static NbDossiers As Long: Static oFSO As Object: Dim oDir As Object, oSubDir As Object, First_Call As Boolean
    If TypeOf Folder Is Object  Then
        First_Call = False: Set oDir = Folder
    Else
        First_Call = True: Erase tbl: NbDossiers = 0
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        If Right(Folder, 1) <> "\" Then Folder = Folder & "\"
        Set oDir = oFSO.getfolder(Folder)
    End If
    On Error Resume Next
    NbDossiers = NbDossiers + 1: ReDim Preserve tbl(1 To NbDossiers): tbl(NbDossiers) = oDir.path
    For Each oSubDir In oDir.subfolders
        If Err.Number = 0 Then
            FSO_List_DOSSIER oSubDir
            Else: Err.Clear
        End If
    Next oSubDir
    On Error GoTo 0
    If First_Call Then
        FSO_List_DOSSIER = False
        If NbDossiers > 0 Then FSO_List_DOSSIER = tbl
    End If
End Function

Sub Test()
    clearAll
  
    tabl = FSO_List_DOSSIER(maitre)
    
    Cells(2, 1).Resize(UBound(tabl), 1) = Application.Transpose(tabl)

    MsgBox "La liste des dossier est faite en colonne 1" & vbCrLf & " séparation des segmentS DES pathS en colonne", vbOKOnly

    Columns("A:A").TextToColumns Destination:=Range("A:A"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Other:=True, OtherChar _
             :="\", TrailingMinusNumbers:=True

    MsgBox "suppression des noms en doublon pour mettre en 2vidence l'indentation de l'arborescence", vbOKOnly

    With ActiveSheet.UsedRange
        For c = 1 To .Cells(.Cells.Count).Column
            For l = .Cells(.Cells.Count).Row To 2 Step -1
                If .Cells(l, c) = .Cells(l - 1, c) Then .Cells(l, c) = ""
            Next
        Next
    .EntireColumn.AutoFit
    End With
End Sub