Créer dossier et avec sous-dossiers en fonction de lignes

Bonjour,

Je souhaiterais ajouter les sous dossiers en fonction des données d'une colonne.

Ma colonne A (catégorie de produit) n'est pas unique et dispose de plusieurs sous-dossiers associés.

Cependant mon code créé uniquement un sous dossier en ne prenant que la première ligne associée à une sous catégorie mais ne vient pas créer de dossiers supplémentaires. En bref, il me créé bien le dossier avec les catégorie - Chocolat mais ne me créé qu'un sous dossier chocolat lait, et pas de sous dossiers chocolat noir, chocolat praline, chocolat blanc...

Mon code

Sub créer_dossier()
'variables
Dim SYSTEME As Worksheet
Dim lstrw As Long
Dim categorie As String
Dim chemin_dossier As String
Dim sous_categorie As String
Dim chemin_sous_dossier As String
'identifier la feuille
Set SYSTEME = Worksheets(1)
'dernière ligne
lstrw = SYSTEME.Cells(Rows.Count, 1).End(xlUp).Row
'boucle sur les données
For i = 4 To lstrw
categorie = SYSTEME.Cells(i, 1)
sous_categorie= SYSTEME.Cells(i, 2)
chemin_dossier = "C:\xxx\Documents\Test2\" & categorie& "\"
chemin_sous_dossier = chemin_sous_dossier & sous_categorie & "\"
'verifier existence du dossier
If Dir(chemin_dossier, vbDirectory) <> vbNullString Then
'dossier existe
Else
'cérer le dossier
MkDir (chemin_dossier)
MkDir (chemin_sous_dossier)
End If
Next
End Sub

Merci d'avance pour votre aide.

Bonjour AG74 et

Une petite présentation ICI serait la bienvenue

Si vous ne l'avez pas encore fait, je vous invite à lire :
- La charte du forum et notamment :

- Quelques fonctionnalites du forum à connaître

Regardez aussi les petites icônes mises à votre disposition dans la barre de menu qui :
- vous permettent de poster un code (</>)
- de citer une phrase (" ")
- ou de clôturer un fil lorsque vous avez terminé (V)

Merci pour votre participation

Cordialement

bonjour,

une proposition (non testée)

Sub créer_dossier()
    'variables
    Dim SYSTEME As Worksheet
    Dim lstrw As Long
    Dim categorie As String
    Dim chemin_dossier As String
    Dim sous_categorie As String
    Dim chemin_sous_dossier As String
    'identifier la feuille
    Set SYSTEME = Worksheets(1)
    'dernière ligne
    lstrw = SYSTEME.Cells(Rows.Count, 1).End(xlUp).Row
    'boucle sur les données
    For i = 4 To lstrw
        categorie = SYSTEME.Cells(i, 1)
        sous_categorie = SYSTEME.Cells(i, 2)
        chemin_dossier = "C:\xxx\Documents\Test2\" & categorie & "\"
        chemin_sous_dossier = chemin_dossier & sous_categorie & "\"
        'verifier existence du dossier
        If Dir(chemin_dossier, vbDirectory) = "" Then
            'créer le dossier
            MkDir (chemin_dossier)
        End If
        If Dir(chemin_sous_dossier, vbDirectory) = "" Then
            'créer sous dossier
            MkDir (chemin_sous_dossier)
        End If
    Next
End Sub

Merci beaucoup, cela fonctionne.