Copiar archivos que se encuentran en carpetas y sub carpetas a nuevo destino
Buen sr. Dante, le pido de ayuda nuevamente,
Le explico. Tengo una lista de nombres de archivos ls cuales estos archivos se encuentran algunos en carpeta y otro en sus sub carpetas, lo que quiero es que lo busque y lo copie a una nueva carpeta los archivos de la lista.
Le adjunto el codigo y la imagen de la nueva estructura.
Lo que esta de amarillo es lo que falta agregar,
Le agradezco de antemano me pueda ayudar.
Slds, cordiales
Jose Montalvo
Sub COPIAR_ARCHIVOS()
rutao = Range("B2")
rutad = Range("B4")
exten = Range("B6")
'
If rutao = "" Or rutad = "" Or exten = "" Then
MsgBox "Completa los datos"
Exit Sub
End If
'
If Right(rutao, 1) <> "\" Then rutao = rutao & "\"
If Right(rutad, 1) <> "\" Then rutad = rutad & "\"
'
u = Range("A" & Rows.Count).End(xlUp).Row
Range("B9:B" & u + 9).ClearContents
'
contador = 0
For i = 9 To u
arch = Cells(i, "A")
If Dir(rutao & arch & exten) <> "" Then
FileCopy rutao & arch & exten, rutad & arch & exten
contador = contador + 1
Cells(i, "B") = "SI"
Else
Cells(i, "B") = "NO"
End If
Next
MsgBox "Archivos copiados: " & contador, vbInformation, "COPIAR ARCHIVOS "
End Sub
2 Respuestas
Te anexo la macro, pon todo el código en un módulo:
Sub CopiarArchivos()
'Por.Dante Amor
ruta = [B2]
incluye = UCase([B3])
dest = [B4]
ext = [B6]
'
If ruta = "" Or incluye = "" Or dest = "" Or ext = "" Then
MsgBox "Complete los datos"
Exit Sub
End If
'
If Right(ruta, 1) <> "\" Then ruta = ruta & "\"
If Right(dest, 1) <> "\" Then dest = dest & "\"
If UCase(incluye) = "SI" Then incluir = True Else incluir = False
u = Range("A" & Rows.Count).End(xlUp).Row
If u < 9 Then u = 9
Range("B9:B" & u).ClearContents
For i = 9 To u
archivo = Cells(i, "A") & ext
carpeta = BuscarArchivo(ruta, incluir, archivo)
If carpeta = "" Then
Cells(i, "B") = "NO"
Else
FileCopy carpeta & archivo, dest & archivo
Cells(i, "B") = "SI"
End If
Next
MsgBox "Fin"
End Sub
'
Function BuscarArchivo(ruta, incluir, archivo)
'Por.Dante Amor
'Set MyObject = New Scripting.FileSystemObject
Set MyObject = CreateObject("Scripting.FileSystemObject")
Set mySource = MyObject.GetFolder(ruta)
For Each myfile In mySource.Files
If UCase(myfile.Name) = UCase(archivo) Then
existeen = mySource.Path
BuscarArchivo = existeen & "\"
Exit Function
End If
Next
If incluir Then
For Each mySubFolder In mySource.SubFolders
existeen = BuscarArchivo(mySubFolder.Path, incluir, archivo)
If existeen <> "" Then
BuscarArchivo = existeen & "\"
Exit Function
End If
Next
End If
End Function'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Te paso unos links que te pueden servir
http://www.programarexcel.com/2015/11/macro-copia-carpetas-y-archivos.html
http://www.programarexcel.com/2014/01/listar-archivos-y-subcarpetas-con-macro.html
http://www.programarexcel.com/2015/11/otro-forma-copiar-archivos-y-carpetas.html
Busca en http://www.programarexcel.com/p/home.html encontrarás cientos de macros de ejemplos.
¡Gracias!
GRACIAS POR LOS LINKS,
disculpa los revise y no encontré lo que buscaba,
le agradezco por su tiempo.