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:

Sheet1:(Data)


The cat stretched
Jacob stood on his tiptoes
The cat Stretched
The car turned the corner
Kelly twirled in circles
She opened the door
Aaron made a picture
I'm so sorry
I danced like any thing




Sheet 2:(Words 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 (http://www.vbaexpress.com/forum/member.php?9803-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