Copier un fichier dans plusieurs répertoires

Sub Test()
Dim Dossier As Object, Chemin As String, ACopier As String
Dim fd As FileDialog, fs As Object, f As Object
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
If .Show = -1 Then
If .SelectedItems.Count <> 1 Then Exit Sub
ACopier = .SelectedItems(1)
End If
End With
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
If .Show = -1 Then
If .SelectedItems.Count <> 1 Then Exit Sub
Chemin = .SelectedItems(1)
End If
End With
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getfolder(Chemin)
For Each Dossier In f.SubFolders
FileCopy ACopier, Dossier.Path & "\" & Split(ACopier, "\")(UBound(Split(ACopier, "\")))
Next
End Sub