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').