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

Hey there
Make sure you read the forum rules http://www.excelforum.com/forum-rule...rum-rules.html - please make sure you place code tags around your code as it makes it difficult to read otherwise.
A few things - the problem is due to not iterating through the ranges containing the word you are searching for. You will only get one result - you write the sheet name to A3 in Results Sheet and then find the next free row which will always be A4 - to do what you want is a little more complicated. Without a sample workbook I do not know how your data is set out (is the data always between column A & I for example). A sample workbook always makes it easier to give you a solution.
Anyway I have attached a sample workbook - you can try it out and try to search for (help or test). You need to have a function that finds all the ranges containing the row with the search word. Also you rarely every need to Activate or Select in your code - you can condense this down. Finally make sure you exit the sub prior to the error trapping otherwise the error message will always be raised.
Have a look at the attached workbook - if you need more help or clarification just post any problems you are having.

Option Explicit


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

Dim wsI As Worksheet
Dim wsO As Worksheet
Dim wsH As Worksheet
Dim WhatFor As String
Dim keyWord As Range, keyWords As Range
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.Range("A5:I6").Copy Destination:=wsO.Range("A1")
wsO.Range("C1").Value = "Search = " & WhatFor
wsO.Range("C1").Font.Bold = True
wsO.Range("A3").CurrentRegion.ClearContents
For Each wsH In ActiveWorkbook.Worksheets
If wsH.Name <> "Search Results" Then
wsO.Range("A" & wsO.Cells(Rows.Count, "A").End(xlUp).Row + 1).Value = wsH.Name
Set keyWords = FindAll(SearchRange:=wsH.UsedRange, FindWhat:=WhatFor, _
        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, _
        MatchCase:=False, BeginsWith:=vbNullString, EndsWith:=vbNullString, _
        BeginEndCompare:=vbTextCompare)
    If keyWords Is Nothing Then
        Debug.Print "Value Not Found"
    Else
        For Each keyWord In keyWords
            Debug.Print "Value Found In Cell: " & keyWord.Address(False, _
                False)
        keyWord.EntireRow.Copy Destination:=wsO.Range("A" & wsO.Cells(Rows.Count, "A").End(xlUp).Row + 1)
        Next keyWord
    End If

End If
Next wsH
Exit Sub

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


Function FindAll(SearchRange As Range, _
                FindWhat As Variant, _
               Optional LookIn As XlFindLookIn = xlValues, _
                Optional LookAt As XlLookAt = xlWhole, _
                Optional SearchOrder As XlSearchOrder = xlByRows, _
                Optional MatchCase As Boolean = False, _
                Optional BeginsWith As String = vbNullString, _
                Optional EndsWith As String = vbNullString, _
                Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range


Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean


CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
    XLookAt = xlPart
Else
    XLookAt = LookAt
End If

For Each Area In SearchRange.Areas
    With Area
        If .Cells(.Cells.Count).Row > MaxRow Then
            MaxRow = .Cells(.Cells.Count).Row
        End If
        If .Cells(.Cells.Count).Column > MaxCol Then
            MaxCol = .Cells(.Cells.Count).Column
        End If
    End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)

On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
        after:=LastCell, _
        LookIn:=LookIn, _
        LookAt:=XLookAt, _
        SearchOrder:=SearchOrder, _
        MatchCase:=MatchCase)

If Not FoundCell Is Nothing Then
    Set FirstFound = FoundCell
    Do Until False
        Include = False
        If BeginsWith = vbNullString And EndsWith = vbNullString Then
            Include = True
        Else
            If BeginsWith <> vbNullString Then
                If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
                    Include = True
                End If
            End If
            If EndsWith <> vbNullString Then
                If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
                    Include = True
                End If
            End If
        End If
        If Include = True Then
            If ResultRange Is Nothing Then
                Set ResultRange = FoundCell
            Else
                Set ResultRange = Application.Union(ResultRange, FoundCell)
            End If
        End If
        Set FoundCell = SearchRange.FindNext(after:=FoundCell)
        If (FoundCell Is Nothing) Then
            Exit Do
        End If
        If (FoundCell.Address = FirstFound.Address) Then
            Exit Do
        End If

    Loop
End If
Set FindAll = ResultRange
End Function

I have changed the code to match your workbook. In the information sheets (Place 1, Place 2 etc) if this how you have the information stored then the code will produce the search results formatted the way you had in your sample. The FindAll function is designed to find EVERY occurrence of the keyword you are searching for and this function will allow you to do this by passing the required parameters and if you want the optional parameters. What it returns is all the ranges that contain the keyword so you just need to iterate through this to find each discrete range and then write the data to the output sheet.
Attached is the revised workbook.
If you have any problems or questions just ask.
PS: If this is the first lot of VBA code you have written you were certainly on the right track and I am impressed for a first go. Well done!

I have added a message box that outputs the number of results for you. I have fixed the problem where if there are no results that the last Sheet name (in this case Place 3) is not written to the Results sheet. I have added a question to ask if you want to search for part of the string or the entire string. So you can search for "rod" or "products" and qualify if you want the entire string searched or only search in part.
If you have any questions just ask.

rjfnc,

Unfortunately you need to post your question in a new thread, it's against the forum rules to post a question in the thread of another user. If you create your own thread, any advice will be tailored to your situation so you should include a description of what you've done and are trying to do. Also, if you feel that this thread is particularly relevant to what you are trying to do, you can surely include a link to it in your new thread.