XL 2019 Créer des dossiers et sous dossiers avec VBA

Sub Comble_les_blancs_V_TBL()
    Cells(1, 8).Resize(3000, 100).Clear
    Dim lig&, c&, Nom$
    Application.ScreenUpdating = False
    With ActiveSheet.UsedRange
        tbl = .Value:        ReDim tbf(UBound(tbl))
        'le premier dossier  en colonne 1
        For i = 3 To UBound(tbl)
            tbl(i, 1) = tbl(2, 1)
           Next
        'les dossier manquant dans le tableau
        For c = 2 To 4
            Nom = ""
            For lig = 3 To UBound(tbl)

                'If WorksheetFunction.CountA(.Cells(lig, 2).Resize(, 4)) > 0 Then
                ca = 0: For x = 2 To 4: ca = ca + (1 And tbl(lig, x) <> ""): Next
                If ca > 0 Then

                    '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

                    If tbl(lig, c) <> "" Then
                        Nom = tbl(lig, c)
                    Else
                        If tbl(lig, c - 1) = tbl(lig - 1, c - 1) And tbl(lig, c - 1) <> "" Then
                            tbl(lig, c) = Nom
                        End If
                    End If
                End If
                'If WorksheetFunction.CountA(.Cells(lig, 1).Resize(, 4)) = 1 Then tbl(lig, 1) = ""
                ca = 0: For x = 1 To 4: ca = ca + (1 * Abs(tbl(lig, x) <> "")): Next
                If ca = 1 Then tbl(lig, 1) = ""

            Next
        Next
    End With
    ' Cells(1, 8).Resize(UBound(tbl), 4) = tbl

    'reconstruction  des chemin  et creation
    racine = Environ("userprofile") & "\desktop\"
    For i = 2 To UBound(tbl)
        For c = 1 To UBound(tbl, 2)
            tbf(i) = tbf(i) & IIf(tbl(i, c) <> "", tbl(i, c) & "\", "")
        Next
        If tbf(i) <> "" Then MkDir racine & tbf(i)
    Next
    Cells(1, 8).Resize(UBound(tbl), 1) = Application.Transpose(tbf)
End Sub

Sub supprimdossiercomplet()
    dossier = Environ("userprofile") & "\desktop\" & Cells(2, 1)
    Shell ("cmd /c RD /S /Q " & dossier)
    Do While Dir(dossier, vbDirectory) <> "": DoEvents: Loop
End Sub