VBA excel search tool

Question

Tried doing a search tool to the excel sheet (VBA) I'm working on. So far every time I search for the text, it ends up filtering only the first row and not any row that has the value I'm looking for. I added a picture to show what it returns and the code as well. Is there anything I need to change to the code to make it search for all the data in the sheet instead of having it to show only one row? Any help is appreciated.

Search result of only the first row:

Sub SearchAllSheets()
Dim ws As Worksheet, OutputWs As Worksheet
Dim rFound As Range
Dim strName As String
Dim count As Long, LastRow As Long
Dim IsValueFound As Boolean

IsValueFound = False
Set OutputWs = Worksheets("sheet1")    '---->change the sheet name as required
LastRow = OutputWs.Cells(Rows.count, "A").End(xlUp).Row

On Error Resume Next
strName = InputBox("What are you looking for?")
If strName = "" Then Exit Sub
For Each ws In Worksheets
    If ws.Name <> "Output" Then
        With ws.UsedRange
            Set rFound = .Find(What:=strName, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
            If Not rFound Is Nothing Then
                Application.Goto rFound, True
                IsValueFound = True
                'MsgBox rFound.Row
                rFound.EntireRow.Copy
                OutputWs.Cells(LastRow + 1, 1).PasteSpecial xlPasteAll
                Application.CutCopyMode = False
                LastRow = LastRow + 1
            End If
        End With
    End If
Next ws
On Error GoTo 0
If IsValueFound Then
   OutputWs.Select
   MsgBox "Result pasted to Sheet Output"
Else
    MsgBox "Value not found"
End If
End Sub

Answer 1

Try this:

Sub SearchAllSheets()
    
    Dim ws As Worksheet, OutputWs As Worksheet
    Dim rFound As Range, IsValueFound As Boolean
    Dim strName As String
    Dim count As Long, LastRow As Long
    
    Set OutputWs = Worksheets("Output")    '---->change the sheet name as required
    LastRow = OutputWs.Cells(Rows.count, "A").End(xlUp).row
    
    strName = Trim(InputBox("What are you looking for?"))
    If strName = "" Then Exit Sub
    For Each ws In Worksheets
        If ws.Name <> OutputWs.Name Then
            Debug.Print "Checking " & ws.Name
            Set rFound = FindAll(ws.UsedRange, strName)
            If Not rFound Is Nothing Then
                Set rFound = rFound.EntireRow
                count = rFound.Cells.count / Columns.count 'how many matched rows?
                Debug.Print "Found " & count & " rows"
                rFound.Copy OutputWs.Cells(LastRow + 1, 1)
                LastRow = LastRow + count
                IsValueFound = True
            End If
        End If
    Next ws
    
    If IsValueFound Then
       OutputWs.Select
       MsgBox "Result(s) pasted to Sheet " & OutputWs.Name
    Else
        MsgBox "Value not found"
    End If

End Sub

'find all cells in range `rng` with value `val` and return as a range
Public Function FindAll(rng As Range, val As String) As Range
    Dim rv As Range, f As Range
    Dim addr As String
 
    Set f = rng.Find(what:=val, After:=rng.Cells(rng.Cells.count), _
        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False)
    If Not f Is Nothing Then addr = f.Address()
    
    Do Until f Is Nothing
        If rv Is Nothing Then
            Set rv = f
        Else
            Set rv = Application.Union(rv, f)
        End If
        Set f = rng.FindNext(After:=f)
        If f.Address() = addr Then Exit Do
    Loop
    Set FindAll = rv
End Function