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

[sdoppke]

Hi everyone, im try to build a macro that will find a word within a sentence that is in a cell. i.e.

A1="store number 566" I need the macro to select that cell (and stop). After that I will insert the rest of the code to copy and paste a larger area from that point, into another worksheet.

Thanks everyone in advance for any help.

sd

 

[sdoppke]

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

Alpha Frog, i really appreciate your help with this, I played with it for a day to see if i could figure out what was going wrong, but cant (the code is to complex) BTW thanks also for explaing what each line was doing.

The problem im having is 2 things (1 i never mentioned earlier).
1. I also need to exclude a worksheet in its shearch of open workbooks. Worksheet "Store Summary" ( I tried hard to add that myself to no avail)
2. The copy potion is copying everything from the "Found" cell and down. That is too much information. It needs to copy as it would, if we did control+shift+right (which i think it does now) and then control+shift+down).

Anyways, ive asked alot of you an cant tell you how much i appreciate your time and help. I will be sure to pass it on.


sd

 

[AlphaFrog]

Sub Business_Results()

    Dim FindWord As String, Found As Range
    Dim wsDest As Worksheet, ws As Worksheet, wb As Workbook
    Dim Nextrow 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 workbook
        If wb.Name <> ThisWorkbook.Name Then        ' Exclude this workbook
            For Each ws In wb.Sheets                ' Loop through each worksheet of each workbook
                [COLOR="Red"]If ws.Name <> "Store Summary" Then  ' Exclude sheet "Store Summary"[/COLOR]
                    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
                        ' Copy\Paste found store data to the next empty row on Sheet3
                        [COLOR="Red"]ws.Range(Found, ws.Cells(Found.End(xlDown).Row, Found.End(xlToRight).Column)).Copy [/COLOR]_
                            Destination:=wsDest.Range("B" & Nextrow)
                    End If
                End If
            Next ws
        End If
    Next wb
    Application.ScreenUpdating = True
    MsgBox "Copy complete.", vbInformation, "Copy Store Data"

End Sub

 

[sdoppke]

It worked!! I thank you so much for your patience. how did you ever figure that out? I know... practice

sd