Création de dossiers

Bonjour

A partir du fichier joint ou figure une liste, est il possible d automatiser la création d une arborescence de dossiers ?

Le but est de restructurer mes dossiers.

Cdt

Hello,

Une proposition sur base de ton fichier

@+

Option Explicit

Sub CreerArborescence()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim cheminBase As String
    Dim valeur As String
    Dim parties() As String
    Dim chemin As String
    Dim j As Long
    Dim dossier As String

    ' ?? A MODIFIER
    cheminBase = "C:\Users\toto\test\"

    ' Création du dossier racine si besoin
    If Dir(cheminBase, vbDirectory) = "" Then
        MkDir cheminBase
    End If

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 35).End(xlUp).Row

    For i = 5 To lastRow

        valeur = ws.Cells(i, 35).Value
        valeur = CleanText(valeur)

        If valeur <> "" Then

            parties = Split(valeur, "-")
            chemin = cheminBase

            For j = 0 To UBound(parties)

                dossier = CleanText(parties(j))

                If dossier <> "" Then

                    chemin = chemin & dossier & "\"

                    If Dir(chemin, vbDirectory) = "" Then
                        MkDir chemin
                    End If

                End If

            Next j

        End If

    Next i

    MsgBox "Arborescence créée avec succès !", vbInformation

End Sub

Function CleanText(txt As String) As String

    ' Remplace espaces insécables (très fréquent en copier/coller)
    txt = Replace(txt, Chr(160), " ")

    ' Supprime tabulations
    txt = Replace(txt, vbTab, " ")

    ' Trim classique
    txt = Trim(txt)

    ' Supprime espaces multiples
    Do While InStr(txt, "  ") > 0
        txt = Replace(txt, "  ", " ")
    Loop

    CleanText = txt

End Function