Copiar Lista de nombres a nuevo destino determinando su tipo de extensión
Sr. Dante Amor, Tengo una macro que funciona bien pero necesito hacerle unos pequeños cambios para lo que necesito-
1ero. La macro al a darle clic en el botón copiar me pide la extensión y luego la ruta donde se encuentran los nombres de los archivos que están en la fila A1 . ( lo que quisiera es de que en una celda ponga la ruta de origen y otra la ruta de destino y en otra celda poder ingresar la extensión)
2do esta macro al no encontrar un nombre de la lista que esta en la columna A1 se detiene el proceso: ( lo que quiero es de que continué el proceso y que me detecte ya sea poniéndolo de color rojo o con una nota, los archivos que no fueron copiados.)
Solo esas 2 cositas les pido a todo los conocedores, les agradezco de ante mano me puedan ayudar.
Estos son los códigos de la macro:
Sub Copy_files()
Dim Archivo, SubCarpeta, carpeta, archivos, extension, file_origen, file_destino As String
Dim contador As Integer
'Lectura de carpeta y ajustes necesarios
extension = InputBox("Ingrese la extensión, INCLUYENDO EL PUNTO")
carpeta = InputBox("Ingresa la ruta de la carpeta donde buscar:")
If carpeta = "" Then
Exit Sub
ElseIf Right(carpeta, 1) <> "\" Then
carpeta = carpeta & "\"
End If
'Preparación de variables
contador = 1
archivos = Dir(carpeta & "*.*")
'Recorrido del archivo
Do While Len(archivos) > 0
archivos = ActiveSheet.Cells(contador, 1).Value & extension
fn = Dir(archivos & extension)
contador = contador + 1
file_origen = carpeta & archivos
file_destino = ActiveWorkbook.Path & "\" & archivos
On Error GoTo 1
FileCopy file_origen, file_destino
'On Error Resume Next
'On Error GoTo 0
1 On Error GoTo 0
Loop
'1
End Sub
Espero puedan ayudarme, les adjunto una imagen de como necesito que sea la estructura de lo mencionado.
1 Respuesta
H o l a : Te anexo la nueva macro
Sub Copy_files()
'Por.Dante Amor
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'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
¡Gracias!
Dante amor eres lo máximo. es justamente lo que necesitaba. muchas y muchas gracias.
tengo otra consulta lo publicare para que ayudes si no fuera mucha molestia.
Nuevamente muchas gracias.
Slds, cordiales
Jose Montalvo
