Question about the last part of my seaarcher VBA ERROR

[jsoearturh]

i have this code, i was trying to improve i, changing some features, the aim is to somebody can use it just one click, but when the code search for the single or multiple word separated by commas, the new page called Resultados is empty.







Sub BuscadorTuanis()
Dim valoresBuscados As Variant
Dim hojaResultados As Worksheet
Dim filaActual As Long
Dim libroActual As Workbook
Dim hojaActual As Worksheet
Dim rangoActual As Range
Dim valorActual As Variant

Call eliminarFila0

' Aquí abre el textbox para ingresar el valor a buscar
inputValores = Replace(InputBox("Ingrese uno o más valores a buscar, separados por comas"), ", ", ",")
valoresBuscados = Split(inputValores, ",")
If UBound(valoresBuscados) = -1 Then
MsgBox "No se ha ingresado texto a buscar"
Exit Sub
End If

' Verificar si la hoja "Resultados" existe
Dim sheetExists As Boolean
sheetExists = False
For Each hoja In activeWorkBook.Worksheets
If hoja.Name = "Resultados" Then
sheetExists = True
Set hojaResultados = hoja
Exit For
End If
Next hoja

' Si la hoja "Resultados" no existe, se crea
If Not sheetExists Then
Set hojaResultados = activeWorkBook.Sheets.Add(After:=activeWorkBook.Sheets(activeWorkBook.Sheets.Count))
hojaResultados.Name = "Resultados"
End If

' Seleccionar la última fila de la hoja "Resultados"
filaActual = hojaResultados.Cells(hojaResultados.Rows.Count, 1).End(xlUp).Row + 1

' Loop para recorrer: libro activo, hoja activa una a una hasta la última por fila y columna
For Each libroActual In Application.Workbooks
Call quitarFila1
For Each hojaActual In libroActual.Worksheets
Set rangoActual = hojaActual.UsedRange

For Each valorBuscado In valoresBuscados
For Each valorActual In rangoActual
If valorActual = valorBuscado Then
If filaActual = 1 Then
' Copiar la fila de encabezados si es la primera coincidencia
rangoActual.Rows(1).Copy hojaResultados.Cells(filaActual, 1)
filaActual = filaActual + 1
End If
' Copiar la fila encontrada
rangoActual.Rows(valorActual.Row).Copy hojaResultados.Cells(filaActual, 1)
filaActual = filaActual + 1
End If
Next valorActual
Next valorBuscado
Next hojaActual
Next libroActual

If filaActual = 1 Then
' Si no se encontraron coincidencias: muestra mensaje en pantalla.
MsgBox "No se encontraron coincidencias"
Application.DisplayAlerts = False
hojaResultados.Delete
Application.DisplayAlerts = True
Else
Call fittiingColumns
Call EliminarFilasDuplicadasNuevisimo
Call Macro1
Call eliminarfilavacia
End If
End Sub












Sub duplicados()


'Macro agregado para eliminar filas duplicadas: En este punto se hace revision de los duplicados(duplicados: la fila tiene los mismos valores en todas sus celdas en relaci[on a otra) y la eliminacion de los mismos.
Dim ultimaFila As Long
Dim indiceMatch As Long
Dim iCntr As Long
ultimaFila = Range("A65000").End(xlUp).Row

For iCntr = 1 To ultimaFila
If Cells(iCntr, 1) <> "" Then
indiceMatch = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & ultimaFila), 0)
If iCntr <> indiceMatch Then
Cells(iCntr, 2).EntireRow.Delete xlShiftUp
iCntr = iCntr - 1
End If
End If
Next



End Sub




Sub fittiingColumns()

'
' fittiingColumns Macro
'

'Acomodando o rellenando las columnas al texto
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select

End Sub

Sub comprobarCelda()


For i = 3 To 10
If IsEmpty(Cells(i, 1)) Then
Range("a1").EntireRow.Delete
End If
Next i


End Sub

Sub EliminarFilasDuplicadas()
Dim datos As Variant
Dim filas As Long, columnas As Long
Dim i As Long, j As Long, k As Long

'Obtener los datos de la hoja activa
datos = ActiveSheet.UsedRange.Value
filas = UBound(datos, 1)
columnas = UBound(datos, 2)

'Recorrer las filas de abajo hacia arriba
For i = filas To 2 Step -1
'Comprobar si la fila actual es igual a alguna de las filas superiores
For j = i - 1 To 1 Step -1
If Not IsError(Application.Match(datos(i, 1), datos(j, 1), 0)) Then
'Las dos filas tienen el mismo valor en la primera celda
Dim iguales As Boolean
iguales = True
For k = 2 To columnas
If datos(i, k) <> datos(j, k) Then
'La fila no es completamente igual
iguales = False
Exit For
End If
Next k
If iguales Then
'Eliminar la fila duplicada
Rows(i).Delete
Exit For
End If
End If
Next j
Next i
End Sub

Sub quitarFila1()

Dim rango As Range
Set rango = Range("c1:J1")
If WorksheetFunction.CountA(rango) = 0 Then
Rows(1).Delete


End If

End Sub


Sub eliminarFilasVacias()
Dim ultimaFila As Long
Dim rango As Range

ultimaFila = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set rango = Range("C1:Q" & ultimaFila)

For i = ultimaFila To 2 Step -1
If WorksheetFunction.CountA(rango.Rows(i - 1)) = 0 Then
Rows(i).Delete
End If
Next i
End Sub
Sub eliminarFilas()
Dim ultimaFila As Long
Dim rango As Range

ultimaFila = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set rango = Range("C1:L" & ultimaFila)

For i = ultimaFila To 2 Step -1
If WorksheetFunction.CountA(rango.Rows(i - 1)) = 0 Then
Rows(i).Delete
End If
Next i
End Sub


Sub Macro1()
'
' Macro1 Macro
'

'
Cells.Select
Selection.Font.Size = 10
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection
.HorizontalAlignment = xlGeneral
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.RowHeight = 151
Selection.ColumnWidth = 20.27
Cells.EntireRow.AutoFit
Cells.EntireColumn.AutoFit
Range("A2").Select
End Sub


Sub eliminarFila0()

Dim ws As Worksheet
Dim rng As Range

For Each ws In ThisWorkbook.Worksheets
Set rng = ws.Range("c1:i1")
If WorksheetFunction.CountA(rng) = 0 Then
ws.Rows(1).Delete
End If

Next ws
End Sub


Sub EliminarFilasDuplicadasNuevisimo()
Dim rng As Range
Dim i As Long, j As Long, k As Long
Dim numFilas As Long
Dim filaIgual As Boolean

numFilas = 100 ' número máximo de filas a verificar

Set rng = ActiveSheet.Range("A1").Resize(numFilas, ActiveSheet.UsedRange.Columns.Count)

For i = numFilas To 2 Step -1
filaIgual = True
For j = i - 1 To 1 Step -1
For k = 1 To rng.Columns.Count
If rng.Cells(i, k).Value <> rng.Cells(j, k).Value Then
filaIgual = False
Exit For
End If
Next k
If filaIgual Then
rng.Rows(i).Delete
Exit For
End If
filaIgual = True
Next j
Next i
End Sub


Sub eliminarfilavacia()
For fila = 1 To 65536
If Cells(fila, 4).Value = "0" Then
Rows(fila).Delete
End If
Next fila
End Sub

 

[sijpie]

Hi jsoearturh, welcome to the board.

Next time you post code, please post it inbetween code brackets: press the little VBA icon at the top of the post window. Then paste your code. This will ensure that the code keeps its indentation and that the various elements are nicely coloured.

Also, Help the person trying to help you!! Take out any code that is irrelevant to your problem. You have four or five subs in your code which are not used by the search sub. So take them out.

Your relevant code is

Option Explicit

Sub BuscadorTuanis()
    Dim valoresBuscados As Variant
    Dim hojaResultados As Worksheet
    Dim filaActual As Long
    Dim libroActual As Workbook
    Dim hojaActual As Worksheet
    Dim rangoActual As Range
    Dim valorActual As Variant
    
    Call eliminarFila0
    
    ' Aquí abre el textbox para ingresar el valor a buscar
    inputValores = Replace(InputBox("Ingrese uno o más valores a buscar, separados por comas"), ", ", ",")
    valoresBuscados = Split(inputValores, ",")
    If UBound(valoresBuscados) = -1 Then
        MsgBox "No se ha ingresado texto a buscar"
        Exit Sub
    End If
    
    ' Verificar si la hoja "Resultados" existe
    Dim sheetExists As Boolean
    sheetExists = False
    For Each hoja In ActiveWorkbook.Worksheets
        If hoja.Name = "Resultados" Then
            sheetExists = True
            Set hojaResultados = hoja
            Exit For
        End If
    Next hoja
    
    ' Si la hoja "Resultados" no existe, se crea
    If Not sheetExists Then
        Set hojaResultados = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))
        hojaResultados.Name = "Resultados"
    End If
    
    ' Seleccionar la última fila de la hoja "Resultados"
    filaActual = hojaResultados.Cells(hojaResultados.Rows.Count, 1).End(xlUp).Row + 1
    
    ' Loop para recorrer: libro activo, hoja activa una a una hasta la última por fila y columna
    For Each libroActual In Application.Workbooks
        Call quitarFila1
        For Each hojaActual In libroActual.Worksheets
            Set rangoActual = hojaActual.UsedRange
            
            For Each valorBuscado In valoresBuscados
                For Each valorActual In rangoActual
                    If valorActual = valorBuscado Then
                        If filaActual = 1 Then
                            ' Copiar la fila de encabezados si es la primera coincidencia
                            rangoActual.Rows(1).Copy hojaResultados.Cells(filaActual, 1)
                            filaActual = filaActual + 1
                        End If
                        ' Copiar la fila encontrada
                        rangoActual.Rows(valorActual.Row).Copy hojaResultados.Cells(filaActual, 1)
                        filaActual = filaActual + 1
                    End If
                Next valorActual
            Next valorBuscado
        Next hojaActual
    Next libroActual
    
    If filaActual = 1 Then
        ' Si no se encontraron coincidencias: muestra mensaje en pantalla.
        MsgBox "No se encontraron coincidencias"
        Application.DisplayAlerts = False
        hojaResultados.Delete
        Application.DisplayAlerts = True
    Else
        Call fittiingColumns
        Call EliminarFilasDuplicadasNuevisimo
        Call FormatR
        Call eliminarfilavacia
    End If
End Sub



Sub fittiingColumns()

'
' fittiingColumns Macro
'

    'Acomodando o rellenando las columnas al texto
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select

End Sub


Sub quitarFila1()

    Dim rango As Range
    Set rango = Range("c1:J1")
    If WorksheetFunction.CountA(rango) = 0 Then
        Rows(1).Delete
    
    
    End If

End Sub



Sub FormatR()
'

    Cells.Select
    Selection.Font.Size = 10
    With Selection.Font
'  Formatting code - not relevant
    End With
    Selection.RowHeight = 151
    Selection.ColumnWidth = 20.27
    Cells.EntireRow.AutoFit
    Cells.EntireColumn.AutoFit
    Range("A2").Select
End Sub


Sub eliminarFila0()

    Dim ws As Worksheet
    Dim rng As Range
    
    For Each ws In ThisWorkbook.Worksheets
        Set rng = ws.Range("c1:i1")
        If WorksheetFunction.CountA(rng) = 0 Then
            ws.Rows(1).Delete
        End If
    
    Next ws
End Sub


Sub EliminarFilasDuplicadasNuevisimo()
    Dim rng As Range
    Dim i As Long, j As Long, k As Long
    Dim numFilas As Long
    Dim filaIgual As Boolean
    
    numFilas = 100 ' número máximo de filas a verificar
    
    Set rng = ActiveSheet.Range("A1").Resize(numFilas, ActiveSheet.UsedRange.Columns.Count)
    
    For i = numFilas To 2 Step -1
        filaIgual = True
        For j = i - 1 To 1 Step -1
            For k = 1 To rng.Columns.Count
                If rng.Cells(i, k).Value <> rng.Cells(j, k).Value Then
                    filaIgual = False
                    Exit For
                End If
            Next k
        If filaIgual Then
            rng.Rows(i).Delete
            Exit For
        End If
        filaIgual = True
        Next j
    Next i
End Sub


Sub eliminarfilavacia()
    For fila = 1 To 65536
        If Cells(fila, 4).Value = "0" Then
            Rows(fila).Delete
        End If
    Next fila
End Sub

I will have a look at it later