Sub Transfert()
Dim dossier1$, dossier2$, fso As Object, tablo, i&
dossier1 = ThisWorkbook.FullName
dossier1 = Left(dossier1, InStrRev(dossier1, "\") - 1)
dossier2 = Left(dossier1, InStrRev(dossier1, "\"))
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
tablo = Sheets("Transfert").UsedRange.Resize(, 2)
For i = 2 To UBound(tablo)
fso.movefile dossier1 & "\" & tablo(i, 2), dossier2 & tablo(i, 1) & "\" & tablo(i, 2)
Next
End Sub