Identify the Words if its matches highlight the value VBA

Sample data:

Code:

Sub HighlightMatchingWords()
Dim lastRowSheet1 As Long
Dim lastRowSheet2 As Long
Dim i As Long
Dim j As Long
Dim cellValueSheet1 As String
Dim cellValueSheet2 As String
Dim wordsSheet1 As Variant
Dim wordsSheet2 As Variant
Dim wordIndexSheet1 As Long
Dim wordIndexSheet2 As Long
Dim wordSheet1 As String
Dim wordSheet2 As String
' Get the last row of data in column A for Sheet1
lastRowSheet1 = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, 1).End(xlUp).Row
' Get the last row of data in column A for Sheet2
lastRowSheet2 = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, 1).End(xlUp).Row
' Loop through each row of data in column A for Sheet1
For i = 1 To lastRowSheet1
' Get the value in column A for the current row in Sheet1
cellValueSheet1 = Sheets("Sheet1").Cells(i, 1).Value
' Split the string into words for Sheet1
wordsSheet1 = Split(cellValueSheet1, " ")
' Loop through each row of data in column A for Sheet2
For j = 1 To lastRowSheet2
' Get the value in column A for the current row in Sheet2
cellValueSheet2 = Sheets("Sheet2").Cells(j, 1).Value
' Split the string into words for Sheet2
wordsSheet2 = Split(cellValueSheet2, " ")
' Loop through each word in Sheet1
For wordIndexSheet1 = 0 To UBound(wordsSheet1)
' Loop through each word in Sheet2
For wordIndexSheet2 = 0 To UBound(wordsSheet2)
' If the words match, highlight the word in Sheet1
If StrComp(wordsSheet1(wordIndexSheet1), wordsSheet2(wordIndexSheet2), vbTextCompare) = 0 Then
wordSheet1 = wordsSheet1(wordIndexSheet1)
' Highlight the word in Sheet1
Sheets("Sheet1").Cells(i, 1).Characters(InStr(cellValueSheet1, wordSheet1), Len(wordSheet1)).Font.ColorIndex = 3 ' Highlight in red
Sheets("Sheet1").Cells(i, 2).Value = Sheets("Sheet1").Cells(i, 2).Value & " " & word
End If
Next wordIndexSheet2
Next wordIndexSheet1
Next j
Next i
End Sub

i tried this im not getting 100% accuracy can anyone help?

Here is one way to achieve this using .Find. I have commented the code so you should not have a problem understanding it. If you do then simply ask.

Code:

Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rng As Range
Dim aCell As Range, bCell As Range
Dim InputAr As Variant
Dim i As Long     
'~~> Set this to the relevant sheet
Set ws = Sheet1
'~~> This is the range where the text nees to be colored
Set rng = ws.Range("A1:A6")
'~~> This is the range where you have the keywords
InputAr = ws.Range("D1:D5")
'~~> Loop through the seach keywords
For i = LBound(InputAr) To UBound(InputAr)
'~~> Find the text
Set aCell = rng.Find(What:=InputAr(i, 1), LookIn:=xlFormulas, LookAt:=xlPart)
'~~> If found
If Not aCell Is Nothing Then
Set bCell = aCell
'~~> Color the text
ColorText aCell, InputAr(i, 1)
'~~> Find the next occurance
Do
Set aCell = rng.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell = bCell Then Exit Do
ColorText aCell, InputAr(i, 1)
End If
Loop
'~~> Set the found range to Nothing
Set aCell = Nothing
End If
Next i
End Sub
'~~> Proc to color the text
Private Sub ColorText(r As Range, keyword As Variant)
Dim sPos As Long
Dim TxtLen As Long
'~~> Set the starting position
sPos = InStr(1, r.Value2, keyword, vbTextCompare)
'~~> Get the length
TxtLen = Len(keyword)
'~~> Color the text
r.Characters(Start:=sPos, Length:=TxtLen).Font.Color = RGB(255, 0, 0)
End Sub

Screenshot:

You can try:

Sub Test()
'Identify both sheets
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets("Sheet2")
'Retrieve the last used row per sheet
Dim lr1 As Long: lr1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
Dim lr2 As Long: lr2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
'Define both ranges to work with
Dim rng1 As Range: Set rng1 = ws1.Range("A1:A" & lr1)
Dim rng2 As Range: Set rng2 = ws2.Range("A1:A" & lr2)
'Initialize an regex object
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "\b(?:" & Join(Application.Transpose(rng2.Value), "|") & ")\b"        
'Loop each cl in rng1
For Each cl In rng1
If .Test(cl.Value) Then
For Each m In .Execute(cl.Value)
cl.Characters(m.FirstIndex + 1, m.Length).Font.Color = vbRed
Next
End If
Next
End With
End Sub

This would result in something like the below:

Note: The use of a regular expression made it possible to:

• Distinguish between true and false positives (e.g.: 'DISORDERLY NUMBERPLATES' <> 'DISORDERLY NUMBER');

• Find multiple of the same substrings in a single cell (e.g.: 'TRAFFIC COPS STUCK IN TRAFFIC').