Dim Cell As Range, Chemin As String, FS
Set FS= CreateObject("Scripting.FileSystemObject")
Chemin = "C:\essai\"
On Error Goto FinBoucle
Redim Liste(1 to 1)
For Each Cell In Range("A2:A" & Range("A65536").End(xlUp).Row)
'remplace les a par la colonne consernée
If Cell <> "" Then
MkDir Chemin & Cell
FS.CopyFolder "C:\type", chemin & cell.value
end if
ChDir Chemin & Cell.Value
FinBoucle:
Next
End Sub