Macro para buscar datos

Hola experto tengo la siguiente macro para buscar un dato en varios libros que se encuentran en una carpeta determinada, pero no logro hacer que funcione, y de ser así que solo busque el dato y me lo copie en una celda x(por ejemplo en el rango b3) .
Sub BusqVsFiles()
Dim MiCarpeta As String, MisArchivos As String, MiClave As String
MiCarpeta = Trim(Sheets("INICIO").Range("C7").Value) & IIf(Right(Trim(Sheets("INICIO").Range("C7").Value), 1) = "\", "", "\")
MisArchivos = Trim(Sheets("INICIO").Range("C8").Value)
MiClave = Trim(Sheets("INICIO").Range("C9").Value)
aBuscar = Trim(Sheets("INICIO").Range("C10").Value)
encontr = False
With Application.FileSearch
.LookIn = MiCarpeta
.SearchSubFolders = True
.Filename = MisArchivos
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
For i = 1 To .FoundFiles.Count
DirFile = .FoundFiles(i)
Workbooks.Open Filename:=DirFile, UpdateLinks:=False, Password:=""
Application.Calculation = xlManual
ActiveWorkbook.Unprotect Password:=MiClave
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
'* TAREA A EFECTUAR en archivo: BUSCAR DATO EN TODOS LOS ARCHIVOS *'
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
For sht = 1 To Sheets.Count
Sheets(sht).Select
Set c = Cells.Find(aBuscar, LookIn:=xlValues)
If c Is Nothing Then
encontr = False
Next i
If encontr = False Then MsgBox "El valor " & aBuscar & "no fue encontrado en los " & i - 1 & " archivos revisados", vbCritical, "NO ESTA, (parece)"
Else
MsgBox "Su búsqueda de " & aBuscar & " no obtubo resultados ", vbInformation, "Info No Encontrada!!!"
Application.DisplayAlerts = False
ActiveWorkbook.Close
Windows("Busca Archivos 2").Activate
Sheets("INICIO").Select
Set c = Nothing
Exit Sub
Else
encontr = True
c.Select
MsgBox "Su búsqueda de " & aBuscar & " fue exitosa ", vbInformation, "Info Encontrada!!!"
Exit Sub
End If
Next
Set c = Nothing
'==========================================================================
' FIN tarea en archivo
'==========================================================================
Next i
If encontr = False Then MsgBox "El valor " & aBuscar & "no fue encontrado en los " & i - 1 & " archivos revisados", vbCritical, "NO ESTA, (parece)"
Else
MsgBox "No se encontró ningún archivo " & MisArchivos & " en " & Chr(10) & MiCarpeta
End If
End With
End Sub

1 Respuesta

Respuesta
1
Te dejo la rutina ajustada. Solo te queda completar en la sección donde te marco, una vez encontrado el registro buscado.
Sub BusqVsFiles()
'AJUSTADA X ELSAMATILDE
Dim MiCarpeta As String, MisArchivos As String, MiClave As String
MiCarpeta = Trim(Sheets("INICIO").Range("C7").Value) & IIf(Right(Trim(Sheets("INICIO").Range("C7").Value), 1) = "\", "", "\")
MisArchivos = Trim(Sheets("INICIO").Range("C8").Value)
MiClave = Trim(Sheets("INICIO").Range("C9").Value)
aBuscar = Trim(Sheets("INICIO").Range("C10").Value)
encontr = False
'para no ver el movimiento de hojas
Application.ScreenUpdating = False
With Application.FileSearch
.LookIn = MiCarpeta
.SearchSubFolders = True
.Filename = MisArchivos
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
'AQUÍ ABRE CADA LIBRO DE LA CARPETA
    For i = 1 To .FoundFiles.Count
    DirFile = .FoundFiles(i)
    Workbooks.Open Filename:=DirFile, UpdateLinks:=False, Password:=""
    Application.Calculation = xlManual
    ActiveWorkbook.Unprotect Password:=MiClave
'AQUÍ RECORRE LAS HOJAS DE CADA LIBRO ENCONTRADO EN LA CARPETA
    For sht = 1 To Sheets.Count  'recorre las hojas en busca del valor
        Sheets(sht).Select
        Set c = Cells.Find(aBuscar, LookIn:=xlValues)
        If Not c Is Nothing Then
            encontr = True
            c.Select
            '--------------AQUÍ ENCONTRÓ EL TEXTO BUSCADO------------
            MsgBox "Su búsqueda de " & aBuscar & " fue exitosa ", vbInformation, "Info Encontrada!!!"
'--------------Aquí es donde debes incluir las instrucciones que necesitas ejecutar con la celda encontrada
            '
            '
            '---Luego de hacer todo lo que necesitas con este libro debes cerrarlo
            Application.DisplayAlerts = False
            ActiveWorkbook. Close
            Windows("Copia de Busca Archivos 2.xls").Activate
            Sheets("INICIO").Select
            Exit Sub
        End If
    Next
    Set c = Nothing
    If encontr = False Then
        Application.DisplayAlerts = False
        ActiveWorkbook.Close
        Windows("Copia de Busca Archivos 2.xls").Activate
        Sheets("INICIO").Select
    End If
'PASA AL LIBRO SGTE
    Next i
    If encontr = False Then MsgBox "El valor " & aBuscar & " no fue encontrado en los " & i - 1 & " archivos revisados", vbCritical, "NO ESTA, (parece)"
    Set c = Nothing
    Exit Sub
Else
    MsgBox "No se encontró ningún archivo " & MisArchivos & " en " & Chr(10) & MiCarpeta
End If
End With
End Sub
Como siempre excelente gracias, solo necesito que haga algo pero no lo he conseguido, que en esta parte:
'--------------AQUÍ ENCONTRÓ EL TEXTO BUSCADO------------
            MsgBox "Su búsqueda de (" & aBuscar & ") fue exitosa ,en (" & i - 1 & ") de (" & i + 1 & ") archivos analizados ", vbInformation, "Info Encontrada!!!"
Le diga al usuario que ha encontrado la palabra en por archivos de z analizados
donde por = el total de archivos analizados
donde z = el total de archivos de la carpeta
y no logro que me diga eso, pero en esta parte si lo dice y no se cual es el problema :
If encontr = False Then MsgBox "El valor : ( " & aBuscar & " ) no fue encontrado en los " & i - 1 & " archivos revisados", vbCritical, "NO ESTA, (parece)"
Ya te enviaré libro con rutina y comentarios.
Sdos
Elsa

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

(Macro) Necesito recorrer Columnas (Range) entre fechas según el valor de 2 celdas

Tengo esta macro que llama a otro archivo y luego recorre el archivo desde donde es llamado. Sub Carga_Operacion() Dim Response As String Dim Fini As Date Dim Fter As Date Dim hora1 As String, fecha1 As String, user1 As String destino =...
1 respuesta

¿Cómo hago para añadir en una nueva hoja de calculo?VBA

Tengo el siguiente código que copie de un ejemplo que descargue pero cuando quiero añadir lo que hace es hacerlo en la misma hoja de calculo toda la información de las textbox, ¿Cómo haría para hacer que cada vez que añada un nuevo cliente aparezca...
3 respuestas

Error 2147417848(80010108) en excel 2013

Tengo un problema con una código en vba que no logro resolver. El código pertenece a un formulario. Tengo uno prácticamente igual en otro formulario -que trabaja con otra tabla -y anda bien, pero con este no hay caso. El código es el que pego a...
1 respuesta

Posición de celdas con un texto

Tenía esta macro desarrollada para que me informe la posición de las celdas en las que contiene un texto buscado: Sub buscar_cosas() On Error Resume Next Application.ScreenUpdating = False Range("J:K").Clear 'Esto debería ser variable... (sólo sirve...
1 respuesta