Macro que realice búsqueda en carpeta externa y subcarpetas de esta a partir de dato en una celda

FELIZ DÍA DE REYES :3

Buenos días tengo una macro que ya me realiza una búsqueda en carpeta externa toma el dato que va a buscar de la columna B de mi libro de excel pero solo realiza la búsqueda en la carpeta que le asigno en la macro ahora lo que necesito es que a partir de una ruta raíz inicie la búsqueda pero si no encuentra el documento en la carpeta principal la busque en las subcarpetas que contenga esta

Ejemplo

Dato a buscar: reporte23--15

Reportes <------------- carpeta dada en la macro o carpeta raiz

Report23-12-14 <------------------documento en carpeta reportes

Reporte enero <------------ subcarpetas

Report2013 <----------documento en carpeta enero

Reporte semana 1 <------------------------ carpeta dentro de la subcarpeta reporte enero

Reporte febrero <-----------------subcarpeta

Reporte marzo<----------------subcarpeta

Reporte abril<---------------------subcarpeta

Reporte mayo <--------------------- subcarpeta

Reporte23--15 <--------------------------documento que se esta buscando

Reporte junio etc

Esta es la macro que tengo

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Act.Por.Dante Amor
If Target.Column <> 2 Then Exit Sub 'sólo se ejecutará en col B'
If Target.Row < 9 Then Exit Sub 'sólo se ejecuta a partir de la fila 9'
If Target.Value = " " Or Target.Value = "" Then Exit Sub no se ejecutara en celdas vacias
'ChDir "C:\Users\cari\Documents\libros\" 'ruta de carpeta donde estan los documentos
ChDir ThisWorkbook.Path & "\"
nombre = Target.Value
If UCase(Right(nombre, 4)) = ".PDF" Then
nuevo = Left(nombre, Len(nombre) - 4)
Else
nuevo = nombre
End If
arch = Dir(CurDir() & "\" & "*" & nuevo & "*.pdf")
If arch <> "" Then
If MsgBox("el archivo existe. Desea abrirlo??", vbYesNo, "ATENCION") = vbNo Then Exit Sub
'ActiveWorkbook.FollowHyperlink CurDir() & "\" & arch
Shell "C:\Program Files (x86)\Adobe\Reader 9.0\Reader\AcroRd32.exe " & arch

Else: y = MsgBox("no fue localizado desea buscarlo manualmente", vbYesNo, "ATENCION")
If y = vbNo Then Exit Sub
On Error GoTo salida
ChDir "C:\Users\cari\Documents\libros\"
archivo = Application.GetOpenFilename
If archivo = False Then Exit Sub
Shell "C:\Program Files (x86)\Adobe\Reader 9.0\Reader\AcroRd32.exe " & archivo
Exit Sub
End If
salida: MsgBox "Listo"
End Sub

Espero se pueda realizar lo que pretendo para hacer mas completa y funcional esta macro de antemano muchas gracias :3

1 Respuesta

Respuesta
1

H o l a:

Te anexo la macro actualizada y un par de funciones para realizar búsquedas en subcarpetas, subsubcarpertas y todas las subcarpetas.

Observa que al principio de la macro está declarada la variable rutas, es preciso que esa línea vaya al principio de todas las macros.

Dim rutas As New Collection
'
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Por.Dante Amor
    If Target.Column <> 2 Then Exit Sub 'sólo se ejecutará en col B'
    If Target.Row < 9 Then Exit Sub 'sólo se ejecuta a partir de la fila 9'
    If Target.Value = " " Or Target.Value = "" Then Exit Sub 'no se ejecutara en celdas vacias
    'ChDir "C:\Users\cari\Documents\libros\" 'ruta de carpeta donde estan los documentos
    ChDir ThisWorkbook.Path & "\"
    'ChDir "C:\trabajo\"
    Set rutas = Nothing
    nombre = Target.Value
    If UCase(Right(nombre, 4)) = ".PDF" Then
        nuevo = Left(nombre, Len(nombre) - 4)
    Else
        nuevo = nombre
    End If
    arch = encuentraarch(nuevo)
    If arch <> "" Then
        If MsgBox("el archivo existe. Desea abrirlo??", vbYesNo, "ATENCION") = vbNo Then Exit Sub
        'ActiveWorkbook.FollowHyperlink arch
        Shell "C:\Program Files (x86)\Adobe\Reader 9.0\Reader\AcroRd32.exe " & arch
    Else
        If MsgBox("no fue localizado desea buscarlo manualmente", vbYesNo, "ATENCION") = vbNo Then Exit Sub
        On Error GoTo salida
        ChDir "C:\Users\cari\Documents\libros\"
        archivo = Application.GetOpenFilename
        If archivo = False Then Exit Sub
        Shell "C:\Program Files (x86)\Adobe\Reader 9.0\Reader\AcroRd32.exe " & archivo
        Exit Sub
    End If
salida:     MsgBox "Listo"
End Sub
'
Function encuentraarch(nuevo)
'Por.Dante Amor
    On Error Resume Next
    pPath = CurDir()
    rutas.Add pPath
    pPath = pPath & "\"
    Call agregadir(pPath)
    For Each sd In rutas
        dato = sd & "\*" & nuevo & "*.pdf"
        arch = Dir(sd & "\*" & nuevo & "*.pdf")
        Do While arch <> ""
            encuentraarch = sd & "\" & arch
            Exit Function
        Loop
    Next
    Set rutas = Nothing
End Function
'
Sub agregadir(lpath)
'Por.Dante Amor
    '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
Felices reyes. Recuerda valorar la respuesta.Sal u dos

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas