Extracción de ficheros tras sincronizar directorios
Dispongo de esta macro, que amablemente Dante Amor me proporcionó, a la que necesito realizar dos "mejoras" para que realice dos operaciones más de las que realiza hasta ahora...
Esta es la macro, que busca desde una carpeta de trabajo llamada CAJAS (con subcarpetas) por su nombre (sin extensión) ficheros en otra carpeta llamada CAJAS-ALMACEN (con subcarpetas), y se copia a CAJAS, a la subcarpeta correspondiente, todos los ficheros que encuentra con el mismo nombre (sin extensión) en cada subcarpeta de CAJAS-ALMACEN, borrando previamente el fichero que utilizó para la comparación de la carpeta CAJAS:
Sub SincronizarDirectorios()
'Por.Dante Amor
Application.DisplayAlerts = False
d1 = "C:\Users\SANTIAGO\Desktop\Cajas-Almacen\"
d2 = "C:\Users\SANTIAGO\Desktop\Cajas\"
'
Set fso = CreateObject("scripting.filesystemobject")
Set carpeta = fso.getfolder(d1)
For Each subcarpeta In carpeta.subfolders
b = subcarpeta.Name
For Each arch In subcarpeta.Files
a = arch.Name
a2 = InStrRev(a, ".")
a3 = Left(a, a2 - 1)
dir1 = d1 & b & "\"
dir2 = d2 & b & "\"
otros = Dir(dir2 & a3 & ".*")
If otros <> "" Then
Do While otros <> ""
Kill dir2 & otros
otros = Dir()
Loop
FileCopy dir1 & a, dir2 & a
End If
Next
Next
MsgBox "Terminado"
End Sub
Ahora bien, (primera modificación) me encuentro con que no sólo tengo ficheros con el mismo nombre, sino que además los hay con el mismo nombre (exacto), y algunos que llevan añadido _002, _003, _004 y _005 en el nombre del fichero, es decir, buscando T01ESAB22, debería copiarse al directorio de trabajo si existen en el almacén todas las que se llamen (sin extensión) T01ESAB22_002, T01ESAB22_003, T01ESAB22_004 y T01ESAB22_005, pero éstos no los pilla ahora mismo tal y como está la macro.
Necesitaría que cogiese también estos ficheros.
La segunda mejora es que me listase en es fichero, llamado Listado.xls, (del que adjunto imagen y proporciono a quien me lo pida), colocando los que haya encontrado con las terminaciones _002, _003, _004 y _005 en las celdas que te indico, pero sólo las que encuentre en el almacén con estas terminaciones, basándose en la columna G de este fichero, y colocándolas a partir de la columna H en la fila que corresponda con el nombre de la imagen.
Esto me resolverá un verdadero problema de trabajo.
No diga gracias a quien pueda ayudarme, porque no hay suficiente agradecimiento para una ayuda tan desinteresada como la de los expertos...
Especialmente agradecido a Dante Amor por su alta capacidad para resolver .
1 Respuesta
Te anexo la macro actualizada.
Ejecuta la macro en tu libro y sobre la hoja donde tienes las referencias.
Sub SincronizarDirectorios()
'Por.Dante Amor
Application.DisplayAlerts = False
d1 = "C:\Users\SANTIAGO\Desktop\Cajas-Almacen\"
d2 = "C:\Users\SANTIAGO\Desktop\Cajas\"
'd1 = "C:\trabajo\1\"
'd2 = "C:\trabajo\2\"
'
Set fso = CreateObject("scripting.filesystemobject")
Set carpeta = fso.getfolder(d1)
For Each subcarpeta In carpeta.subfolders
b = subcarpeta.Name
For Each arch In subcarpeta.Files
a = arch.Name
a2 = InStrRev(a, ".")
a3 = Left(a, a2 - 1)
dir1 = d1 & b & "\"
dir2 = d2 & b & "\"
otros = Dir(dir2 & a3 & ".*")
If otros <> "" Then
Do While otros <> ""
Kill dir2 & otros
otros = Dir()
Loop
FileCopy dir1 & a, dir2 & a
End If
'
terminaciones = Dir(dir1 & a3 & "_*.*")
Do While terminaciones <> ""
FileCopy dir1 & terminaciones, dir2 & terminaciones
Set b = Columns("A").Find(a3, lookat:=xlWhole)
If Not b Is Nothing Then
fila = b.Row
If Rows(b.Row).Find(terminaciones) Is Nothing Then
u = Cells(fila, Columns.Count).End(xlToLeft).Column + 1
If u < Columns("H").Column Then u = Columns("H").Column
Cells(fila, u) = terminaciones
End If
End If
terminaciones = Dir()
Loop
Next
Next
MsgBox "Terminado"
End SubSaludos.Dante Amor
Recuerda valorar la respuesta.
Perdona Dante,
¿Dónde abre el fichero Listado.xls para insertar los nombres de los ficheros encontrados?
Gracias,.
Es que la macro va en un fichero de macros que ya tengo, y el fichero Listado.xlsx es otro.
¿Dónde podría llamarlo y abrirlo para que inserte los nombres de los ficheros que ha encontrado?
La macro no abre ningún fichero, pasa la macro al archivo fichero y ejecuta la macro sobre la hoja que tiene las referencias.
No lo entiendo, pero de todas formas, gracias.
Y perdona por mi ignorancia.
Saludos, Santiago.
Aquí me quedo hasta que quede claro.
- Tienes un archivo llamado "Listado"
- Te envié una macro.
Bien, la macro que te envié la tienes que poner en el archivo "Listado".
Para que la macro funcione tienes que abrir el archivo "Listado", selecciona la hoja donde tienes tus referencias y ejecutas la macro.
No es necesario que tengas la macro en otro archivo. Es más fácil tener la macro y los datos en el mismo archivo.
ok, gracias.
He probado en varias ocasiones la macro, y ahora sólo me actualiza las subcarpetas desde CAJAS-ALAMACEN a CAJAS aquellas imágenes que tienen el sufijo _002 , _003, _004 y _005, pero no las que no tienen sufijo.
¿A qué puede deberse?
¿Podrías echarle un vistazo?.
Por si necesitas los ficheros te los dejo en tu correo.
Espero que puedas ayudarme y no ser demasiado "pesado", pero la verdad es que la necesito.
Por enésima vez y por tu paciencia y ayuda, Gracias.
Para que actualice un archivo, deberá existir en la carpeta destino.
Es decir, tengo en la carpeta origen el archivo: imagen123.jpeg, en la carpeta destino, no tengo el archivo, entonces la macro NO copia el archivo.
Otro ejemplo: tengo en la carpeta origen en archivo: foto555.jpeg, en la carpeta destino, tengo el archivo foto555.bmp, entonces la macro borra el archivo foto555.bmp y copia el archivo foto555.jpg
Esa es la condición que pusiste. Esa parte ya existía en la macro original. Tampoco lo solicitaste en las mejoras.
Si quieres el cambio crea una nueva pregunta, especificando que no importa si el archivo origen existe en la carpeta destino, se tiene que copiar si o si.
Dante, en las carpetas la macro inicial que me hiciste se comporta ok, va perfecto.
Pero cuando ejecuto la macro mejorada con tu último cambio, me actualiza en la carpeta CAJAS sólo los que tienen sufijo y me da un error.
Da en la ejecución un "error 91". Variable de objeto o bloque With no establecido..
Puedes comprobarlo. yo lo he comprobado y me ocurre esto.
Si estoy en un error y no es posible arreglarlo, pues ya bastante has hecho por mí, entonces ya le buscaré yo la solución.
Gracias y perdón por mi insistencia.
Por si puediera ser, te adjunto por e-mail cuadro por si estoy equivocado en el concepto o al explicarlo, pero así es como se debería comportar la macro modificada, pero no lo hace sólo con los que llevan el sufijo "_00x".
Gracias mil.
Si lo consideras otra pregunta, dímelo y te la hago sobre la marcha.
Prueba con esta macro:
Sub SincronizarDirectorios2()
'Por.Dante Amor
Application.DisplayAlerts = False
d1 = "C:\Users\SANTIAGO\Desktop\Cajas-Almacen\"
d2 = "C:\Users\SANTIAGO\Desktop\Cajas\"
'd1 = "C:\trabajo\1\"
'd2 = "C:\trabajo\2\"
'
Set fso = CreateObject("scripting.filesystemobject")
Set carpeta = fso.getfolder(d1)
For Each subcarpeta In carpeta.subfolders
b = subcarpeta.Name
For Each arch In subcarpeta.Files
a = arch.Name
a2 = InStrRev(a, ".")
a3 = Left(a, a2 - 1)
dir1 = d1 & b & "\"
dir2 = d2 & b & "\"
otros = Dir(dir2 & a3 & ".*")
If otros <> "" Then
Do While otros <> ""
Kill dir2 & otros
otros = Dir()
Loop
FileCopy dir1 & a, dir2 & a
End If
Next
Next
'
For Each subcarpeta In carpeta.subfolders
b = subcarpeta.Name
For Each arch In subcarpeta.Files
a = arch.Name
a2 = InStrRev(a, ".")
a3 = Left(a, a2 - 1)
dir1 = d1 & b & "\"
dir2 = d2 & b & "\"
'
terminaciones = Dir(dir1 & a3 & "_*.*")
Do While terminaciones <> ""
FileCopy dir1 & terminaciones, dir2 & terminaciones
Set b = Columns("A").Find(a3, lookat:=xlWhole)
If Not b Is Nothing Then
fila = b.Row
If Rows(b.Row).Find(terminaciones) Is Nothing Then
u = Cells(fila, Columns.Count).End(xlToLeft).Column + 1
If u < Columns("H").Column Then u = Columns("H").Column
Cells(fila, u) = terminaciones
End If
End If
terminaciones = Dir()
Loop
Next
Next
MsgBox "Terminado"
End SubSi te marca error, dime qué mensaje de error te aparece.
Presiona el botón depurar y dime qué fila de la macro está en amarillo.
Dante, ahora no da el error, pero no realiza las misma tareas con los ficheros de igual condición, me explico, de los que debería traerse de CAJAS-ALMACEN a CAJAS, sólo lo hace con algunos. Revisadas las subcarpetas antes y después, te adjunto listado de os que ha copiado (verde) y los que no (rojo).
Sólo a procesado los que tienen sufijo _00x del primer fichero que ha encontrado, del resto, no.
Las carpetas son exactamente las mismas que te mandé, y la ejecución corresponde a esta macro que me has mandado última.
G R A C I A S.....
La macro funciona bien, pero tiene una condición que tú estableciste, solamente copia el archivo si ya existe, pero si no existe no lo copia, te anexo el cambio para que te copie todos los archivos:
Sub SincronizarDirectorios2()
'Por.Dante Amor
Application.DisplayAlerts = False
d1 = "C:\Users\SANTIAGO\Desktop\Cajas-Almacen\"
d2 = "C:\Users\SANTIAGO\Desktop\Cajas\"
'd1 = "C:\trabajo\1\"
'd2 = "C:\trabajo\2\"
'
Set fso = CreateObject("scripting.filesystemobject")
Set carpeta = fso.getfolder(d1)
For Each subcarpeta In carpeta.subfolders
b = subcarpeta.Name
For Each arch In subcarpeta.Files
a = arch.Name
a2 = InStrRev(a, ".")
a3 = Left(a, a2 - 1)
dir1 = d1 & b & "\"
dir2 = d2 & b & "\"
otros = Dir(dir2 & a3 & ".*")
If otros <> "" Then
Do While otros <> ""
Kill dir2 & otros
otros = Dir()
Loop
End If
FileCopy dir1 & a, dir2 & a
Next
Next
'
For Each subcarpeta In carpeta.subfolders
b = subcarpeta.Name
For Each arch In subcarpeta.Files
a = arch.Name
a2 = InStrRev(a, ".")
a3 = Left(a, a2 - 1)
dir1 = d1 & b & "\"
dir2 = d2 & b & "\"
'
terminaciones = Dir(dir1 & a3 & "_*.*")
Do While terminaciones <> ""
FileCopy dir1 & terminaciones, dir2 & terminaciones
Set b = Columns("A").Find(a3, lookat:=xlWhole)
If Not b Is Nothing Then
fila = b.Row
If Rows(b.Row).Find(terminaciones) Is Nothing Then
u = Cells(fila, Columns.Count).End(xlToLeft).Column + 1
If u < Columns("H").Column Then u = Columns("H").Column
Cells(fila, u) = terminaciones
End If
End If
terminaciones = Dir()
Loop
Next
Next
MsgBox "Terminado"
End Sub
