XL 2010 Déplacement de fichiers dans des dossiers portant le même nom

Bonjour,
j'ai récupéré une macro sur ce site et essayé de l'adapter à mes besoins.
Le besoin: déplacer ~9000 fichiers, deux types de produits: des fichiers simples avec extension .ai et d'autres, des compositions INDD, le même nom avec 3 extensions différentes formant le produit.
Le but est de déplacer les fichiers dans des dossiers portant le même nom, j'ai utilisé une macro qui a bien fait son travail pour créer les dossiers.
j'ai adapté cette macro:

Sub DeplacerFichiers()
Dim DosFichiers As String, DosDestination As String
Dim Fso As Object
Dim Dos As Object
Dim Fichier As Object
Dim nbcf As Integer, nbcd As Integer
ChDir "J:\DEPLACEMENT_4"
'crée l'objet FileSystemObject
Set Fso = CreateObject("Scripting.FileSystemObject")
DosFichiers = "J:\DEPLACEMENT_4"
DosDestination = "J:\DEPLACEMENT_5\" & fichier2
'vérifie que les deux dossiers existe bien sur le disque
If Fso.FolderExists(DosFichiers) = False Then Exit Sub
If Fso.FolderExists(DosDestination) = False Then Exit Sub

'récupère la collection des fichiers
'dans le dossier d'origine

Set Dos = Fso.GetFolder(DosFichiers)

'parcours la collection en recherchant dans le dossier de destination
'le dossier correspondant au numéro du fichier
'si le dossier existe, le fichier est déplacé

For Each Fichier In Dos.Files


nbcf = InStr(Fichier.Name, ".") - 1
fichier2 = Left(Fichier.Name, nbcf)
'If fichier2 = "11_MARCEL_SEMBAT" Then Stop
DosDestination = "J:\DEPLACEMENT_5\" & fichier2
If Fso.FolderExists(DosDestination) = True Then
Fso.MoveFile DosFichiers & "\" & Fichier.Name, Fichier.Name
'Fso.MoveFile Fichier.Name, DosDestination & "\" & Fichier.Name
'Fso.MoveFile DosFichiers & Fichier.Name, DosDestination & "\" & Fichier.Name
End If

Next Fichier

End Sub

j'ai testé 3 types d'instructions:
la première:
Fso.MoveFile DosFichiers & "\" & Fichier.Name, Fichier.Name
déplace tous les fichiers dans c:\Bibliothèques\Documents

les deux autres :

Fso.MoveFile Fichier.Name, DosDestination & "\" & Fichier.Name
Fso.MoveFile DosFichiers & Fichier.Name, DosDestination & "\" & Fichier.Name

m'indiquent Erreur d'éxécution '53': Fichier introuvable

Merci pour votre aide.
Bon week-end
Henry