Macro para Comparar - Sincronizar el contenido de dos directorios
Necesito una macro que me compare el contenido de dos directorios que tienen la misma estructura de subdirectorios (1 nivel), es decir, uno tal que C:\CAJAS\, y el otro que es C:\CAJAS-ALMACEN\, con un nivel de subdirectorio cada uno, iguales, de nombres CAJ-001, CAJ-002, CAJ-003 y así sucesivamente, hasta 36 subdirectorios.
La macro debe entrar en C:\CAJAS\CAJ-001\ y ver los ficheros que contenga. Una vez hecho ésto debe ir a C:\CAJAS-ALMACEN\CAJ-001\ y comprobar cuáles de ellos están también allí. Los que haya encontrado iguales allí debe copiarlos a C:\CAJAS\CAJ-001\, sobreescribiendo los que sean necesarios, sin pedir confirmación. Así en todos los subdirectorios.
1 respuesta
Te anexo la macro
Sub SincronizarDirectorios()
'Por.Dante Amor
Application.DisplayAlerts = False
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
dir1 = d1 & b & "\"
dir2 = d2 & b & "\"
If Dir(dir2 & a) <> "" Then
FileCopy dir1 & a, dir2 & a
End If
Next
Next
MsgBox "Terminado"
End SubSaludos.Dante Amor
Recuerda valorar la respuesta.
Como cada vez que me has ayudado.
¡Gracias mil!
Un saludo.
La pruebo mañana y te cuento.
Gracias.
Cambia los nombres de los directorios por tus directorios:
d1 = "C:\trabajo\1\" d2 = "C:\trabajo\2\"
d1 = "C:\CAJAS\" d2 = "C:\CAJAS-ALMACEN\"
Ya lo hice Dante, y va "de lujo".
Sólo una pequeña cuestión: ¿Podría ser que se obviasen a la hora de comparar, las extensiones de los ficheros, es decir, que sólo atendiera a comparar los nombres de los ficheros?, porque para mi sería muchísimo más operativa, ya que compara y sincroniza imágenes, y las tengo de varios formatos, con extensiones diferentes.
Otra vez gracias.
Te anexo la macro actualizada
Sub SincronizarDirectorios()
'Por.Dante Amor
Application.DisplayAlerts = False
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
FileCopy dir1 & a, dir2 & a
End If
Next
Next
MsgBox "Terminado"
End Sub
¡Gracias por tu inestimable ayuda!
Voy a probarla.
Saludos. Santiago.
Perdona Dante, por abusar de tu ayuda.
Comentarte:
Como ahora puede encontrar ficheros con extensión distinta, y lo hace ok, sólo faltaría que borrase, antes de copiar el fichero al directorio "CAJAS" desde el directorio "CAJAS-ALMACEN" el fichero que le sirvio para comparar del directorio "CAJAS", ya que si no me duplica nombres con distintas extensiones.
Gracias, puedas o no, que ya has hecho bastante.
Un saludo, Santiago.
Son varias peticiones en una sola, podrías crear una nueva pregunta por cada petición.
