Find Specific Word from the cell by referring a list (VBA)

[sethu29]

HI Support,

I've a excel workbook with two spreadsheet.

The first sheet(Data) contains list of data. i want to find out if it matches with any specific word from sheet2 (Words to Find) and print the word in Column B.

If there no match found against sheet2(Words to find) , then for that cell, the result should be "No match found". Can you provide a VBA code for this.

I have attached a sample workbook for this. Thank you in Advance

For Example:

Sheet1Data)

1. The cat stretched
2. Jacob stood on his tiptoes
3. The cat Stretched
4. The car turned the corner
5. Kelly twirled in circles
6. She opened the door
7. Aaron made a picture
8. I'm so sorry
9. I danced like any thing

Sheet 2Words to Find)
The Cat
The car
Jacob
in Circles
so sorry
the Door
a Picture
Stretched
Any thing

[Paul_Hossler]

Option Explicit


Sub SearchWords()
    Dim rCell As Range, rFind As Range
    Dim vFind As Variant, vTemp As Variant
    Dim i As Long, iFound As Long
    Dim sFind As String, sSearch As String
    
    'if range not selected then get out
    If Not TypeOf Selection Is Range Then Exit Sub


    'build UC string of words to find separated by #
    Set rFind = Worksheets("Words to find").Cells(1, 1).CurrentRegion
    Set rFind = rFind(2, 1).Resize(rFind.Rows.Count - 1, 1)
    sFind = UCase(Join(Application.WorksheetFunction.Transpose(rFind), "#"))
    
    'check selection for each data word
    For Each rCell In Selection.Columns(1).Cells
            
        sSearch = rCell.Text
        If Right(sSearch, 1) = "." Then sSearch = Left(sSearch, Len(sSearch) - 1)
    
        vTemp = Split(sSearch)
        
        For i = LBound(vTemp) To UBound(vTemp)
            If InStr(sFind, UCase(vTemp(i)) & "#") > 0 Then
                rCell.Offset(0, 1).Value = rCell.Offset(0, 1).Value & vTemp(i) & ";"
            End If
        Next i
    
        'remove last added ";"
        If Len(rCell.Offset(0, 1)) > 0 Then rCell.Offset(0, 1).Value = Left(rCell.Offset(0, 1), Len(rCell.Offset(0, 1)) - 1)
    Next
End Sub

[sethu29]

HI Paul_Hossler ,

The requirement is to find out even if the find word is of two words.

The Cat
The car
Jacob
in Circles
so sorry
the Door
a Picture
Stretched
Any thing

[Paul_Hossler]

I misunderstood

This should be better

Option Explicit


Sub SearchWords()
    Dim rCell As Range, rFind As Range, rSearch As Range
    Dim vFind As Variant, vTemp As Variant
    Dim iFind As Long
    Dim sFind As String, sSearch As String
    
    'if range not selected then get out
    If Not TypeOf Selection Is Range Then Exit Sub


    Set rFind = Worksheets("Words to find").Cells(1, 1).CurrentRegion
    Set rFind = rFind(2, 1).Resize(rFind.Rows.Count - 1, 1)
    sFind = Join(Application.WorksheetFunction.Transpose(rFind), "#")
    vFind = Split(sFind, "#")
    
    
    For Each rCell In Selection.Columns(1).Cells
            
        sSearch = UCase(rCell.Text)
        If Right(sSearch, 1) = "." Then sSearch = Left(sSearch, Len(sSearch) - 1)
        
        For iFind = LBound(vFind) To UBound(vFind)
            If InStr(sSearch, UCase(vFind(iFind))) > 0 Then
                rCell.Offset(0, 1).Value = rCell.Offset(0, 1).Value & vFind(iFind) & ";"
            End If
        Next iFind
    
        'remove last added ";"
        If Len(rCell.Offset(0, 1)) > 0 Then rCell.Offset(0, 1).Value = Left(rCell.Offset(0, 1), Len(rCell.Offset(0, 1)) - 1)
    Next
End Sub