Rutina FindBruteForce

Esta rutina nos permite buscar datos en un tabla especifica en pocas palabras podríamos decir que es una rutina parecida a la función de BUSCARV. El objetivo de esta función es mas que nada proporcionar una rutina el cual los usuarios podrán reutilizar modificar como según les convenga para desarrollar sus propias macros de búsqueda.



Sub FindBruteForce()

Dim i, Aux, Fila As Double

Dim Columna, Col, Col1, j, Hasta As Integer

Dim Cadena, Comparar, Hoja As String

    Aux = 0

    Columna = ActiveCell.Column

    i = ActiveCell.Row

    Set MyPage = Application.InputBox(prompt:="Selecciona Rango Recorrido", Type:=8) 'Range("A5:A12781")

    Set MiTabla = Application.InputBox(prompt:="Selecciona Rango Tabla", Type:=8)

    Col = Application.InputBox(prompt:="Indica Columna a Extraer", Type:=1)

    Hasta = Application.InputBox(prompt:="Indica Cuantas Columnas Extraer", Type:=1)

    Hoja = MiTabla.Worksheet.Name

    'Application.ScreenUpdating = False

    For Each Cell In MyPage

        Cadena = Cell.Value 'Worksheets(ActiveSheet.Name).Cells(Fila, 2).Value

            Set c = Worksheets(Hoja).Range(MiTabla.Address).Find(Cadena, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True)

            If Not c Is Nothing Then

                Do

                    firstAddress = c.Address

                    BusquedaPartida = c.Row

                    Col1 = c.Column

                    Comparar = Worksheets(Hoja).Cells(BusquedaPartida, Col1).Value

                    If Cadena = Trim(Comparar) Then

                        For j = 0 To Hasta - 1

                            ActiveSheet.Cells(i, Columna + j).Value = Worksheets(Hoja).Cells(BusquedaPartida, Col + j).Value

                        Next j

                        Aux = Aux + 1

                        Exit Do

                    Else

                        Set c = Worksheets(Hoja).Range(MiTabla.Address).FindNext(c)

                    End If

                Loop While Not c Is Nothing And c.Address <> firstAddress

            End If

            i = i + 1

            Application.StatusBar = "Contando Total de Registros  " & i & "  Encontrados Hasta Ahora  " & Aux

    Next Cell

    'Application.ScreenUpdating = True

End Sub