Copiar archivos de una carpeta a otra con macro
Espero que me explique bien, y gracias por su ayuda:
Ya tengo este código de macro, el cual copia todos los archivos que están en la carpeta
Creación a la carpeta artistas:
Dim fso As New FileSystemObject fso.CopyFolder "C:\USERDATA\Eduardo\creacion", "C:\USERDATA\Eduardo\artistas" MsgBox "Se copiaron satisfactoriamente los artistas C:\USERDATA\Eduardo\artistas"
Lo que quiero hacer es que si el archivo ya está en la carpeta de artistas que no lo copie y que lo descarte o lo borre.
Por ejemplo: el archivo "a.xlsx" esta en la carpeta de creación y al momento de querer pasarla a artistas y si ya esta, que no lo copie, pero si no esta que siga copiandose los archivos.
No necesariamente tiene que ser el mismo nombre del ejemplo, este puede variar "b.xlsx", "c.xlsx" y así... Ahora sí que puede tener el nombre que sea, pero si no esta se copia y si esta no lo hace.
Encontré una macro pero quisiera que me ayuden a hacer algunos cambios sobre esta macro,
1ero. Esta macro copia los archivos que están en la celda A1 en la ubicación donde se encuentra la macro. (Lo que quisiera es de que en una celda poder ponder la ubicación de origen y la ubicaion de destino donde copiar)
2do Al carle clic en copiar esta me pide que ingrese el tipo de extensión. (Lo que quiero es de que yo pueda ingresar la extensión en una celda)
3ero. La macro al no encontrar un archivo se paraliza el proceso (lo que quiero es de que siga el proceso y me indicque cual no existen ya sea pintándolo de rojo o al costado una nota que diga "no existe archivo" o algo similar para saber que archivo no se llego a copiar.
Les adjunto una imagen de como podría quedar lo mencionado.
Les agradezco de antemano a todos los que me puedan ayudar, mil gracias,
Les dejo mi correo para una comunicación más directa: [email protected]
Esta es la macro de lo mencionado:
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
1 respuesta más de otro experto
Perfecto, estaría mucho mejor.
Si, por favor
Saludos
Me parece que no necesitamos otra macro, prueba con lo siguiente
Dim fso As New FileSystemObject
fso.CopyFolder "C:\USERDATA\Eduardo\creacion", "C:\USERDATA\Eduardo\artistas", False
MsgBox "Se copiaron satisfactoriamente los artistas C:\USERDATA
Por default, el último parámetro (overwrite), es True, sobreescribir, para que no sobreescriba, se debe poner el parámetro False
Prueba y me comentas
Saludos. Dam
Si es lo que necesitas.
Me marca un error
fso.CopyFolder "C:\USERDATA\Eduardo\creación", "C:\USERDATA\Eduardo\artistas", False
Y está igual
En lugar de False, escribe 0:
fso.CopyFolder "C:\USERDATA\Eduardo\creación", "C:\USERDATA\Eduardo\artistas", 0
Ya lo hice y tampoco, no me esta aceptando false, porque escribí true y si dio...
Revisaste la carpeta origen
La palabra creacion debe ir sin acento
Prueba otra vez, y si no hay resultado, creo la macro para copiar archivo por archivo
Saludos. Dam
Te envío la macro que copia los archivos de una carpeta a otra y no sobreescribe los archivos que ya existan
Sub copiaarch()
'copia archivos
'por.dam
co = "C:\USERDATA\Eduardo\creacion\"
cd = "C:\USERDATA\Eduardo\artistas\"
'lee archivos del origen
ChDir co
archi = Dir("*.*")
Do While archi <> ""
With Application.FileSearch
.NewSearch
.LookIn = cd
.FileType = msoFileTypeAllFiles 'msoFileTypeAllFiles
.Filename = archi
.MatchTextExactly = True
'.SearchSubFolders = True ' para buscar en sub carpetas
' ejecuta la búsqueda
If .Execute > 0 Then
'si lo encontró entonces no lo copia
Else
'no está se copia
FileCopy co & archi, cd & archi
If Err.Number <> 0 Then
MsgBox "no se copio " & archi
End If
Err.Number = 0
End If
End With
archi = Dir()
Loop
End SubSaludos.Dam
Si es lo que necesitas.
si verifique que no tuviera acento.
ya intente usar el código y me marca error simplemente ejecutando ChDir
De verdad gracias por la ayuda
Lo siento el error es del with y no se por que, ya le estuve buscando
Es por la versión, ¿tienes 2007 ó 2010?
Tengo que enviarte un código para buscar archivos para tu versión.
Corrijo la macro y te la envío
Me dices qué versión de excel tienes
Saludos. Dam
es 2010
Gracias
Saludos
Cambian mucho las instrucciones?
Saludos
GRacias
Si cambian las instrucciones pero creo que es más sencillo
Esta es la macro
Sub buscaarchivos2007()
'Por.dam
Dim archivos As New Collection
co = "C:\trabajo\USERDATA\Eduardo\creacion\"
cd = "C:\trabajo\USERDATA\Eduardo\artistas\"
ChDir co
archivo = Dir("*.*")
Do While archivo <> ""
archivos.Add (archivo)
archivo = Dir()
Loop
For Each archi In archivos
DirFile = Dir(cd & archi)
If DirFile = "" Then
FileCopy co & archi, cd & archi
End If
Next
End Sub Saludos.Dam
Si es lo que necesitas.