1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48
|
Sub ReDeplacer()
ReDeplacerFichiers "D:\DossierDestination\"
End Sub
Sub ReDeplacerFichiers(DosDestination As String)
Dim TblDossiers
Dim Fso As Object
Dim D As Object
Dim Dos As Object
Dim Dossier As Object
Dim Fichier As Object
Dim NouvDos As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
If Fso.FolderExists(DosDestination) = False Then Exit Sub
Set Dos = Fso.GetFolder(DosDestination)
'parcour la collection de dossiers du dossier de destination
For Each Dossier In Dos.SubFolders
'parcour la collection de fichiers du dossier en cours
For Each Fichier In Dossier.Files
'si le dossier portant le nom du fichier existe, le fichier est déplacé dans ce dossier
'sinon, le dossier est créé et le fichier est ensuite placé dedans
If Fso.FolderExists(Dossier & "\" & Mid(Fichier.Name, InStrRev(Fichier.Name, "-") + 1, Len(Fichier.Name) - InStrRev(Fichier.Name, "-") - 4)) = True Then
Fso.MoveFile Fichier, _
Dossier & "\" & Mid(Fichier.Name, InStrRev(Fichier.Name, "-") + 1, Len(Fichier.Name) - InStrRev(Fichier.Name, "-") - 4) & "\" & Fichier.Name
Else
Set NouvDos = Fso.CreateFolder(Dossier & "\" & Mid(Fichier.Name, InStrRev(Fichier.Name, "-") + 1, Len(Fichier.Name) - InStrRev(Fichier.Name, "-") - 4))
Fso.MoveFile Fichier, _
NouvDos & "\" & Fichier.Name
End If
Next Fichier
Next Dossier
End Sub |
Partager