Como Mejorar código de vba
Solicito de su amable colaboración par poder mejorar un poco una macro que tengo en un archivo de Excel.
Esta macro realiza un proceso en el cual copia un archivo de una ruta especifica y luego lo pega en diferentes rutas o lo remplaza si ya se encuentra.
Sin embargo si el archivo que va hacer remplazado esta en uso detiene la macro, por ende lo que quiero mejorar es que la macro recorra todo el código y al final me muestre en un cuadro de dialogo las rutas que no se logro actualizar o copiar el archivo.
Este es el código que tiene la macro claramente tiene mas de dos rutas.
Sub CopiarArchivo()
Application.ScreenUpdating = False
FileCopy "\\10.26.1.76\apertura programas\SIPEC.accdb", "\\10.26.1.76\sistemas-dec_ygualteros\SIPEC.accdb"
FileCopy "\\10.26.1.76\apertura programas\SIPEC.accdb", "\\10.26.1.76\sistemas-dec_leidy.bran\SIPEC.accdb"
End Sub
1 respuesta
Te anexo la macro actualizada.
Como en el ejemplo, podrás agregar más rutas destino.
La macro copiará el archivo origen en todas las rutas que pongas
Al final te desplegará las rutas donde no se pudo copiar
Sub CopiarArchivo2() 'Act.Por.Dante Amor Application.ScreenUpdating = False Application.DisplayAlerts = False ' 'Poner archivo a copiar arch = "SIPEC.accdb" 'Poner la ruta origen origen = "\\10.26.1.76\apertura programas\" ' 'Especificar rutas ruta1 = "\\10.26.1.76\sistemas-dec_ygualteros\" ruta2 = "\\10.26.1.76\sistemas-dec_leidy.bran\" ruta3 = "c:\trabajo\carpeta\" ruta4 = "c:\trabajo\diario\" rutas = Array(ruta1, ruta2, ruta3, ruta4) ' cad = "" On Error Resume Next For i = LBound(rutas) To UBound(rutas) FileCopy origen & arch, rutas(i) & arch werr = Err.Number If werr <> 0 Then cad = cad & rutas(i) & vbCr End If Err.Number = 0 Next MsgBox "Rutas que no se lograron copiar : " & vbCr & cad End Sub
.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
Buen día Dante,
De antemano muchas gracias por tu ayuda, te comento ajuste el código como me lo indicaste, sin embargo el archivo no lo esta pegando o remplazando
lo estoy ejecutando con una sola ruta pero no lo pega.
Pon la macro con los cambios que hiciste
También quita este línea del código:
On Error Resume Next
Prueba nuevamente y dime qué mensajes te aparecen
Hola Dante, realice tu actualización aun así no me funciona mira el código que coloque, no se si tiene que ver que las rutas se encuentran en RED.
Sub CopiarArchivo()
'Act.Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
'Poner archivo a copiar
arch = "SIPEC.accdb"
'Poner la ruta origen
origen = "\\10.26.1.76\apertura programas\"
'
'Especificar rutas
ruta1 = "\\10.26.1.76\sistemas-decsistemas-dec_andersson.perez\"
rutas = Array(ruta1)
'
cad = ""
'On Error Resume Next
For i = LBound(rutas) To UBound(rutas)
FileCopy origen & arch, rutas(i) & arch
werr = Err.Number
If werr <> 0 Then
cad = cad & rutas(i) & vbCr
End If
Err.Number = 0
Next
MsgBox "Rutas que no se lograron copiar : " & vbCr & cad
End Sub
No está encontrando el archivo o las rutas
Revisa que el archivo esté en la ruta origen
Revisa el nombre de la ruta origen
Revisa el nombre de la ruta1
Revisa espacios, guiones, puntos, etc
Revisa que tengas acceso a las rutas o servidores o carpetas compartidas.
Prueba con unas rutas en tu misma PC que empiecen con C:\"
Hola Dante,
Quiero darte las gracias, la solución fue perfecta tenias razón estaba un poco bloqueado y no me fije que estaba colocando la ruta mal, al revisarlo el día de hoy me di cuenta de mi error y funciona a la perfección.
Nuevamente muchas gracias.
