Macro para buscar archivos txt en múltiples carpetas desde archivo excel

Tengo una buena consulta, resulta que ocupo un macro que me permita buscar desde una lista en excel, todos los archivos en .txt que coincidan y me los copie a otra carpeta destino, buscando y buscando logré conseguir el siguiente macro:

Sub ejemplo()
sheets("hoja1").select
Range("a1").Select
On Error Resume Next
Do While ActiveCell.Value <> ""
inicio = "C:\TXT-Buenos Aires\" & ActiveCell.Value & ".txt"
fin = "C:\TXT\" & ActiveCell.Value & ".txt"
FileCopy inicio, fin
ActiveCell.Offset(1, 0).Select
Loop
End Sub
'antes de correr el macro se debe seleccionar la columna donde se va a hacer la búsqueda

Resulta que si yo lo buscara de una carpeta específica, este macro me sirve de mil maravillas, pero ahora ocupo que no solo recorra una carpeta sino múltiples carpetas, es decir, que me recorra en una carpeta raíz que a su vez contiene múltiples carpetas, me busque los archivos .txt que coinciden con la lista

El formato del nombre de archivo es siempre numérico, ejemplo: 123456789.txt y en la lista está como 123456789

1

1 respuesta

Respuesta
1

Esta sería la macro.

Nota: Al inicio de toda la macro debe ir declarada la variable rutas, es una variable global que se ocupa en las 2 rutinas que te estoy enviando, entonces revisa que quede al principio de tu módulo.

Solamente actualiza las carpetas para inicio y para fin, la macro toma la carpeta inicio para recorrer todas las subcarpetas.

Dim rutas As New Collection
Sub ejemplo()
'Mod.Por.DAM
Sheets("hoja1").Select
Range("a1").Select
On Error Resume Next
inicio = "C:\TXT-Buenos Aires" 'sin la última diagonal
fin = "C:\TXT"" 'sin la última diagonal"
rutas.Add inicio
Call agregadir(inicio & "\")
Do While ActiveCell.Value <> ""
    archo = ActiveCell.Value & ".txt"
    finx = fin & "\" & ActiveCell.Value & ".txt"
    For Each sd In rutas
        arch = Dir(sd & "\*.txt")
        Do While arch <> ""
            If arch = archo Then
                FileCopy sd & "\" & arch, finx
                DoEvents
                Exit For
            End If
            arch = Dir
        Loop
    Next
    ActiveCell.Offset(1, 0).Select
Loop
End Sub
Sub agregadir(lpath)
'Por.DAM
'Agrega directorios
Dim SubDir As New Collection
If Right(lpath, 1) <> "\" Then lpath = lpath & "\"
DirFile = Dir(lpath & "*", vbDirectory)
Do While DirFile <> ""
    'Agrega subdirectorios a collection
    If DirFile <> "." And DirFile <> ".." Then _
        If ((GetAttr(lpath & DirFile) And vbDirectory) = 16) Then _
            SubDir.Add lpath & DirFile
    DirFile = Dir
Loop
For Each sd In SubDir
    rutas.Add sd
    Call agregadir(sd)
Next
End Sub

Saludos. Dante Amor
No olvides finalizar la pregunta.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas