Private Sub CréerDossiers()
Dim Fso As Object
Dim Dossier As String
Dim I As Integer
'crée l'objet FileSystemObject
Set Fso = CreateObject("Scripting.FileSystemObject")
'attention, le dossier doit exister sinon, erreur
Dossier = "D:\TEMP\" 'dossier où seront créé les sous-dossiers
'parcour la plage et crée les dossiers inexistants et copie les fichiers correspondants
'adapter le nom de la feuille
With Worksheets("Feuil1")
For I = 2 To .Cells(.Rows.Count, "X").End(xlUp).Row
'création des dossiers
If Fso.FolderExists(Dossier & .Cells(I, "X").Value) = False Then
Fso.CreateFolder Dossier & .Cells(I, "X").Value
End If
Next I
End With
End Sub
Private Sub CopierFichiers()
Dim Fso As Object
Dim Dossier As String
Dim DossierFichiers As String
Dim I As Integer
'crée l'objet FileSystemObject
Set Fso = CreateObject("Scripting.FileSystemObject")
'attention, les dossiers doivent exister sinon, erreur
Dossier = "D:\TEMP\" 'dossier où seront créé les sous-dossiers
DossierFichiers = "D:\Fichiers a copier\" 'dossier où se trouvent les fichiers à copier
'parcour la plage et crée les dossiers inexistants et copie les fichiers correspondants
'adapter le nom de la feuille
With Worksheets("Feuil1")
For I = 2 To .Cells(.Rows.Count, "X").End(xlUp).Row
'copie des fichiers
If Fso.FileExists(DossierFichiers & .Cells(I, "X").Value & ".xls") = True Then
Fso.CopyFile DossierFichiers & .Cells(I, "X").Value & ".xls", Dossier & .Cells(I, "X").Value & "\", True
End If
Next I
End With
End Sub