Tester l'existence de répertoires à partir d'une liste

    ligne = ligne + 1 ' je passe à la ligne suivante 
    Chemin = Cells(ligne, 4).Text ' j'actualise le répertoire suivant à tester 
     
End If 

Option Explicit

Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long

    Sub Existence_of_Directory()
    Dim ligne As Integer, Chemin As String, Msg As String, NomsRep As Variant, i As Integer, monBool As Boolean
        
        Msg = "Impossible de créer le(s) répertoire(s) suivant(s) :"
        ' la liste des répertoire commence en cellule (6,4)
        ligne = 6
        ' je récupère le contenu des cellules sous forme de chaine de char
        Chemin = Cells(ligne, 4).Text
        ' Tant que les cellules sous la cellule (6,4) ne sont pas vides
        Do While Len(Chemin) <> 0
            'trouve les noms des sous-sous-...-sous répertoires à créer
            NomsRep = Split(Chemin, "\")
            'évite une erreur si le contenu de la cellule se termine par "\"
            If Right(Chemin, 1) = "\" Then ReDim Preserve NomsRep(UBound(NomsRep) - 1)
            monBool = True
            For i = LBound(NomsRep) + 1 To UBound(NomsRep)
                If Nom_Valide(NomsRep(i)) = False Then ' Si un des noms choisis dans le chemin complet n'est pas valide
                    monBool = False
                    Exit For
                End If
            Next i
            If monBool Then
                SHCreateDirectoryEx 0, Chemin, ByVal 0&
            Else
                Msg = Msg & vbCrLf & Chemin
            End If
            ligne = ligne + 1 ' je passe à la ligne suivante
            Chemin = Cells(ligne, 4).Text ' j'actualise le répertoire suivant à tester
        Loop
        If Msg <> "Impossible de créer le(s) répertoire(s) suivant(s) :" Then MsgBox Msg
    End Sub

    Private Function Nom_Valide(ByVal Repertoire As String) As Boolean
    Dim i As Long, Test As Variant
    Const CARS_INVALIDES As String = """,/,\,:,|,<,>,*,?"
    Const MOTS_INVALIDES As String = "con,prn,aux,clock$,nul,com1,com2,com3,com4,com5,com6,com7,com8,com9,lpt1,lpt2,lpt3,lpt4,lpt5,lpt6,lpt7,lpt8,lpt9"
        
            'valeur par défaut
            Nom_Valide = False
            'si le nom du répertoire est vide ou qu'il se termine par " " ou "." Alors ==> FAUTE
            If Len(Trim$(Repertoire)) = 0 Or Right$(Repertoire, 1) = " " Or Right$(Repertoire, 1) = "." Then Exit Function
            
            'si le nom du répertoire contient un caractère interdit Alors ==> FAUTE
            Test = Split(CARS_INVALIDES, ",")
            For i = LBound(Test) To UBound(Test)
                If InStr(1, Repertoire, Test(i)) > 0 Then Exit Function
            Next
            
            'si le nom du répertoire est un mot interdit Alors ==> FAUTE
            Test = Split(MOTS_INVALIDES, ",")
            For i = LBound(Test) To UBound(Test)
                If LCase$(Repertoire) = Test(i) Then Exit Function
            Next
            
            'sinon c'est bon
            Nom_Valide = True
    End Function

Sub Existence_of_Directory()
Dim ligne As Integer
Dim Chemin As String

ligne = 6
Cells(ligne, 4).Select
Chemin = Cells(ligne, 4).Text
 
Do While Len(Chemin) > 0

    If Len(Dir(Chemin, vbDirectory)) = 0 Then
        Cells(ligne, 5).Interior.ColorIndex = 26
        Cells(ligne, 5) = "Not created"
    Else
        Cells(ligne, 5).Interior.ColorIndex = 34
        Cells(ligne, 5) = "Created"
    End If
    ligne = ligne + 1
    Chemin = Cells(ligne, 4).Text
Loop

End Sub