H o l a:
Te anexo la macro.
Dim rutas As New Collection
Sub CopiarArchivosXls()
'Por.Dante Amor
'Copia archivos a una carpeta destino
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    rutadestino = "C:\trabajo\cartas\"
    ruta = "C:\"
    ext = "xls*"
    '
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Selecciona una carpeta"
        .AllowMultiSelect = False
        .InitialFileName = ruta
        If .Show <> -1 Then Exit Sub
        carpeta = .SelectedItems(1)
    End With
    '
    If carpeta = "" Then Exit Sub
    '
    pPath = carpeta & "\"
    rutas.Add carpeta
    Call agregadir(pPath)
    '
    For Each sd In rutas
        arch = Dir(sd & "\*." & ext)
        Do While arch <> ""
            FileCopy sd & "\" & arch, rutadestino & arch
            arch = Dir()
        Loop
    Next
    '
    Set rutas = Nothing
    MsgBox "Fin, copiar archivos xls", vbInformation, "ARCHIVOS"
End Sub
'
Sub agregadir(lpath) 'Agrega directorios
'Por.Dante Amor
    Dim SubDir As New Collection
    If Right(lpath, 1) <> "\" Then lpath = lpath & "\"
    DirFile = Dir(lpath & "*", vbDirectory)
    Do While DirFile <> "" 'Agrega subdirectorios a collection
        If DirFile <> "." And DirFile <> ".." Then _
            If ((GetAttr(lpath & DirFile) And vbDirectory) = 16) Then _
                SubDir.Add lpath & DirFile
        DirFile = Dir
    Loop
    For Each sd In SubDir
        rutas.Add sd
        Call agregadir(sd)
    Next
End Sub
Indicaciones:
- En esta línea de la macro pon la carpeta destino: 
rutadestino = "C:\trabajo\cartas\"
 - Copia todo el código en un módulo.
 - La macro que debes ejecutar es la que tiene el nombre "CopiarArchivosXls"
 
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias