Macro to find a cell with a specific word (when its mixed in with a sentence)

Sub Find_Word()
    
    Dim FindWord As String, Found As Range

    FindWord = [COLOR="Red"]"store number 566"[/COLOR]

    Set Found = Sheets("Sheet1").Cells.Find(What:=FindWord, _
                                            LookIn:=xlValues, _
                                            LookAt:=xlPart, _
                                            SearchOrder:=xlByRows, _
                                            SearchDirection:=xlNext, _
                                            MatchCase:=False)
                                        
    If Not Found Is Nothing Then
        Found.Select
    Else
        MsgBox "No match found."
    End If
        
End Sub

Sub Business_Results()
    Dim FindWord As String, Found As Range
    FindWord = Sheets("MyStoreInfo").Range("B2")
    Set Found = Sheets("Sheet2").Cells.Find(What:=FindWord, _
                                            LookIn:=xlValues, _
                                            LookAt:=xlPart, _
                                            SearchOrder:=xlByRows, _
                                            SearchDirection:=xlNext, _
                                            MatchCase:=False)
                                        
    If Not Found Is Nothing Then
        Found.Select
        Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Sheet3").Select
    Range("B4").Select
    ActiveSheet.Paste
    Range("B4").Select
    Else
        MsgBox "Cannot find store data..."
    End If

End Sub

Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Sheets("GRL Copy and Paste").Select
        Range("A1").Select
        ActiveSheet.Paste

Sub Business_Results()

    Dim FindWord As String, Found As Range
    Dim wsDest As Worksheet, ws As Worksheet, wb As Workbook
    Dim Nextrow As Long, Lastrow As Long

    Set wsDest = ThisWorkbook.Sheets("Sheet3")
    FindWord = ThisWorkbook.Sheets("MyStoreInfo").Range("B2").Value
    
    Application.ScreenUpdating = False
    For Each wb In Application.Workbooks        ' Loop through each open workbook
        If wb.Name <> ThisWorkbook.Name Then    ' Exclude this workbook
            For Each ws In wb.Sheets            ' Loop through each worksheet of each workbook
                Set Found = ws.Range("A:A").Find(What:=FindWord, _
                                                 LookIn:=xlValues, _
                                                 LookAt:=xlPart, _
                                                 SearchOrder:=xlByRows, _
                                                 SearchDirection:=xlNext, _
                                                 MatchCase:=False)
                If Not Found Is Nothing Then
                    Nextrow = wsDest.Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1 ' Next empty row on Sheet3
                    Lastrow = ws.Cells.Find("*", , , , xlByRows, xlPrevious).Row         ' Last used row on Store sheet
                    ' Copy\Paste found store data to the next empty row on Sheet3
                    ws.Range(Found, Found.End(xlToRight)).Resize(Lastrow - Found.Row + 1).Copy _
                        Destination:=wsDest.Range("B" & Nextrow)
                End If
            Next ws
        End If
    Next wb
    Application.ScreenUpdating = True
    MsgBox "Copy complete.", vbInformation, "Copy Store Data"

End Sub