Déplacer liste de dossier

Bonjour à tous,

Je viens tout juste de découvrir le forum.. On y trouve énormément d'astuce (mais je n'ai pas trouver la réponse à comment faire...). Je précise que je suis débutant sur VBA (mais vraiment débutant.. je n'y connais rien pour le moment..

J'ai un petit soucis au boulot...

J'ai un dossier qui comporte environs 4500 dossier (et dans ces dossier il y a un ou deux document de type excel pdf ou word). Je dois trier les 4500 dossier par service.

J'ai donc créer un dossier par service.

Pour chaque service, j'ai la liste du nom des dossiers que je dois transférer dans le dossier du service.

J'ai trouvé le code ci-dessous mais qui visiblement ne bouge que les fichier et non les dossiers..

Existe-il une manipulation pour que les dossiers présent dans la liste bascule automatiquement dans un nouveau dossier ? (J'aimerai faire chaque service un par un)

Sub movefiles()

'Updateby Extendoffice

Dim xRg As Range, xCell As Range

Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog

Dim xSPathStr As Variant, xDPathStr As Variant

Dim xVal As String

On Error Resume Next

Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 8)

If xRg Is Nothing Then Exit Sub

Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

xSFileDlg.Title = " Please select the original folder:"

If xSFileDlg.Show <> -1 Then Exit Sub

xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"

Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

xDFileDlg.Title = " Please select the destination folder:"

If xDFileDlg.Show <> -1 Then Exit Sub

xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"

For Each xCell In xRg

xVal = xCell.Value

If TypeName(xVal) = "String" And xVal <> "" Then

FileCopy xSPathStr & xVal, xDPathStr & xVal

Kill xSPathStr & xVal

End If

Next

End Sub