search multiple worksheets in workbook for keyword then copy entire row to new worksheet

I need to create a macro to search multiple worksheets in a workbook for keyword then copy entire row of every keyword found onto a new worksheet? I have created a code that for some reason only returns the last keyword found on the first worksheet..? Here is what i have come up with so far:

Option Explicit
Option Compare Text

Sub KeywordSearch()
'
' KeywordSearch Macro
'
' Keyboard Shortcut: Ctrl+Shift+S

    Dim LSearchRow As Long
    Dim LCopyToRow As Long
    Dim wsI As Worksheet
    Dim wsO As Worksheet
    Dim sh As Worksheet
    Dim FirstAddress As String, WhatFor As String
    Dim keyword As Range, Sheet As Worksheet
    Dim DataCount1 As Integer
    
    On Error GoTo Err_Execute

    WhatFor = InputBox("Please Enter Keyword", "Search Criteria")
    If WhatFor = Empty Then Exit Sub

        
    If CreateSheetIf("Search Results") Then
        MsgBox ("Search Results was created!")
    End If
    
    Set wsO = Sheets("Search Results")
    wsO.Columns("C").ColumnWidth = 50
    wsO.Columns("B").ColumnWidth = 28
    wsO.Columns("A").ColumnWidth = 20
     
    Set wsI = Sheets(1)
    wsI.Activate
    ActiveSheet.Range("A5:I6").Select
    Selection.Copy
    wsO.Range("A1").PasteSpecial
    wsO.Range("C1").Value = "Search = " & WhatFor
    wsO.Range("C1").Font.Bold = True

 
    wsO.Range("A3:I3").End(xlDown).ClearContents

        
    For Each Sheet In ActiveWorkbook.Worksheets
        If Sheet.Name <> "Search Results" Then
            With Sheet
                wsO.Range("A3").Value = ActiveSheet.Name
                Set keyword = Cells.Find(What:=WhatFor, LookIn:=xlFormulas, _
                                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                MatchCase:=False, SearchFormat:=False)
                

                    If Not keyword Is Nothing Then
                        FirstAddress = keyword.Address

                    Do
                        DataCount1 = Worksheets("Search Results").Range("A" & Rows.Count).End(xlUp).Row + 1
                        keyword.EntireRow.Copy Destination:=Worksheets("Search Results").Range("A" & DataCount1)
                    Loop While Not keyword Is Nothing And keyword.Address <> FirstAddress
                End If
            End With
       End If
    Next Sheet
    
    
                
Err_Execute:
        MsgBox "An error occurred."

End Sub

Function CreateSheetIf(strSheetName As String) As Boolean
    Dim wsTest As Worksheet
    CreateSheetIf = False
     
    Set wsTest = Nothing
    On Error Resume Next
    Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
    On Error GoTo 0
     
    If wsTest Is Nothing Then
        CreateSheetIf = True
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = strSheetName
    End If
     
End Function

Any help would be greatly appreciated