'Auteur: Theze, [url]www.developpez.net[/url]
'adapté par mes soins pour tes besoins :)
Sub Deplacer()
'A adapter
DeplacerFichiers "D:\DossierOrigine\", "D:\Lot\"
End Sub
Private Sub DeplacerFichiers(DosFichiers As String, _
DosDestination As String)
Dim Fso As Object
Dim Dos As Object
Dim Fichier As Object
Dim i as Long
Dim j as Integer
'crée l'objet FileSystemObject
Set Fso = CreateObject("Scripting.FileSystemObject")
'vérifie que le dossier d'origine existe bien sur le disque
If Fso.FolderExists(DosFichiers) = False Then Exit Sub
'If Fso.FolderExists(DosDestination) = False Then mkdir(DosDestination)
'récupère la collection des fichiers
'dans le dossier d'origine
Set Dos = Fso.GetFolder(DosFichiers)
'parcour la collection
'si le dossier n'existe pas, le dossier est créé et le fichier est déplacé
For Each Fichier In Dos.Files
i=i+1
If i>500 Then DosDestination=DosDestination & j+1
If Fso.FolderExists(DosDestination) = False Then Fso.CreateFolder(DosDestination)
Fso.MoveFile DosFichiers & Fichier.Name, _
DosDestination & Left(Fichier.Name, 2) & "\" & Fichier.Name
End If
Next Fichier
End Sub