'### Constante à adapter ###
Const Racine As String = "C:\"
'###########################
Sub Arborescence()
Dim S As Worksheet
Dim var
Dim i&
Dim j&
Dim k&
Dim A$
Dim B$
Dim C$
Dim D$
Set S = ActiveSheet
var = S.Range("a1:g" & S.[g65536].End(xlUp).Row & "")
A$ = Racine & var(1, 3)
On Error Resume Next
MkDir A$
If Err <> 0 Then
If Err = 75 Then
MsgBox "Le dossier " & A$ & " existe déjà"
Else
MsgBox "Erreur : " & Err.Number & vbCrLf & Err.Description
End If
Exit Sub
End If
On Error GoTo 0
For i& = 5 To UBound(var, 1)
If var(i&, 2) <> "" Then
B$ = A$ & "\" & var(i&, 2)
MkDir B$
For j& = i& + 1 To UBound(var, 1)
If var(j&, 2) <> "" Then Exit For
If var(j&, 4) <> "" Then
C$ = B$ & "\" & var(j&, 4)
MkDir C$
For k& = j& + 1 To UBound(var, 1)
If var(k&, 4) <> "" Then Exit For
If var(k&, 7) <> "" Then
D$ = C$ & "\" & var(k&, 7)
MkDir D$
End If
Next k&
End If
Next j&
End If
Next i&
End Sub