Highlight specific text in one cell based on another cell

[nagasree]

I have few values in column I and column H, i have a code which highlights specific words in H column if those words are exactly present in I column.

Drawback is it highlights the works only if they are exactly ditto and are present together, Can any changes be made in the code and make highlight each word even if they are not together



attaching a image of what i want vs what i have, also attaching the existing code.

Dim c1 As Range, c2 As Range, md As Variant, i As Long, w1 As String, os As Long
Set c1 = Range("I2")
Set c2 = Range("H2")

md = Range(c1, Cells(Rows.Count, c1.Column).End(xlUp)).Value

For i = 1 To UBound(md)
If md(i, 1) <> "" Then
w1 = c2.Cells(i, 1).Value
os = InStr(1, w1, md(i, 1), vbTextCompare)
While os > 0
c2.Cells(i, 1).Characters(Start:=os, Length:=Len(md(i, 1))).Font.Color = vbBlue
os = InStr(os + 1, w1, md(i, 1), vbTextCompare)
Wend
End If
Next i

It would be a great help if someone solves my problem.

I got a suggestion to Use Split(md(i, 1), ",") to get an array of words to highlight, and loop over that. and to Trim() each word to remove any spaces at the beginning/end.
but as im very new to vba i dont know how to do it, it would be a great hep if someone helps me out, Thanks in advance.

 

[planetpj]

The cat and the dog are friends cat The cat, dog are friends cat, dog The cat and dog are friends cat dog The cat and dog are friends cat, dog The cat, dog are friends dog

Sub ColorPart()
Dim parts() As String
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastrow
        x = Replace(Cells(i, 2), ", ", " ")
        parts = Split(x, " ")
        For Each p In parts
            pos = InStr(Cells(i, 1), p)
            If pos > 0 Then
                Cells(i, 1).Characters(pos, Len(p)).Font.Color = vbRed
                Cells(i, 1).Characters(pos, Len(p)).Font.Bold = True
            End If
        Next
    Next
End Sub

 

[nagasree]

The cat and the dog are friends cat The cat, dog are friends cat, dog The cat and dog are friends cat dog The cat and dog are friends cat, dog The cat, dog are friends dog

Sub ColorPart()
Dim parts() As String
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastrow
        x = Replace(Cells(i, 2), ", ", " ")
        parts = Split(x, " ")
        For Each p In parts
            pos = InStr(Cells(i, 1), p)
            If pos > 0 Then
                Cells(i, 1).Characters(pos, Len(p)).Font.Color = vbRed
                Cells(i, 1).Characters(pos, Len(p)).Font.Bold = True
            End If
        Next
    Next
End Sub

Hi, Thank you for the code, but where do i specify H column and I column? Its working fine if its in column A and B, but i have other data in those columns, need this color to work on column H and I, can u help me out pleaseee @planetpj

 

[nagasree]

Hi, Thank you for the code, but where do i specify H column and I column? Its working fine if its in column A and B, but i have other data in those columns, need this color to work on column H and I, can u help me out pleaseee @planetpj

Also want it to be case insensitive, like Black in column I and black in column H must be highlighted and it highlights only once, if there are multiple times the same word is present, it must highlight all those words, Thank in advance@planetpj

 

[Anthony47]

Try this other version:

Sub hLight2()
Dim WDs As Range, PHs As Range, mySplitW, mySplitP, HL As Boolean
Dim I As Long, J As Long, k As Long, hStart As Long
'
Set WDs = Range("I2")        'Words begin cell
Set PHs = Range("H2")        'Phrase begin cell
'
Set PHs = Range(PHs, PHs.End(xlDown))
PHs.Font.ColorIndex = xlAutomatic
PHs.Font.Bold = False
For I = 1 To PHs.Rows.Count
    If PHs.Cells(I, 1) <> "" Then
        mySplitP = Split(Replace(PHs.Cells(I, 1), ",", " ", , , vbTextCompare) & " ", " ", , vbTextCompare)
        mySplitW = Split(Replace(WDs.Cells(I, 1), ",", " ", , , vbTextCompare) & " ", " ", , vbTextCompare)
        For J = 0 To UBound(mySplitP)
            If mySplitP(J) <> "" Then
                For k = 0 To UBound(mySplitW)
                    If mySplitW(k) <> "" Then
                        If UCase(mySplitP(J)) = UCase(mySplitW(k)) Or _
                           UCase(mySplitP(J)) = UCase(mySplitW(k) & "s") Then _
                             HL = True Else HL = False
                        If HL Then
                            hStart = InStr(1, Replace(PHs.Cells(I, 1) & " ", ",", " ", , , vbTextCompare), mySplitP(J) & " ", vbTextCompare)
                            If hStart > 0 Then
                                PHs.Cells(I, 1).Characters(Start:=hStart, Length:=Len(mySplitP(J))).Font.Color = vbRed
                                PHs.Cells(I, 1).Characters(Start:=hStart, Length:=Len(mySplitP(J))).Font.Bold = True
                            End If
                        End If
                        If HL Then Exit For
                    End If
                Next k
            End If
        Next J
    End If
Next I

End Sub

It should hilights Cat & cats but not cattle

Bye