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