Highlight Matched Words and Count

[barim]

Hello everybody,

I tried to find anything similar that would solve this problem. I have two columns that would highlight words that match and then in column C to give me the count how many matched. For example in the first line there is only one match and word "Car" should be highlighted. In the second line there are 2 matches "Cars" and "Great" which should also be highlighted and so on. This should not be case sensitive, so "Great" and "great" should be the match. I tried so many similar macros that highlight the whole cell instead of just keyword inside each cell. I am comparing Column A with Column B so all highlights should be placed in Column B. I prefer this to be in VBA but if there is any other solution I am open to that. I appreciate any help on this issue. Thanks.

Compare1	Compare2	Count Matched Words
Driving Car	Car is so useful	1​
Cars are great	Great that we have cars today	2​
Mazda is reliable car	Mazda is good car	3​
Walking is good for your health	Health is precious	2​
Library is so far away	I live so far away	3​

 

[CA_Punit]

Since my xl2bb addin is not working.

Request you to kindly download the file

Highlight Match Words.xlsx

Microsoft Excel Workbook

1drv.ms

 

[Eric W]

Try:

Sub HiLiteWords()
Dim lr As Long, r As Long
Dim w1 As String, w2 As String, ws1 As Variant, w As Variant
Dim loc1 As Long, loc2 As Long, ctr As Long

    lr = Cells(Rows.Count, "A").End(xlUp).Row
    
    For r = 2 To lr
        w1 = Cells(r, "A").Value
        w2 = Cells(r, "B").Value
        ws1 = Split(w1, " ")
        ctr = 0
        For Each w In ws1
            loc1 = InStr(1, " " & w1 & " ", " " & w & " ", vbTextCompare)
            loc2 = InStr(1, " " & w2 & " ", " " & w & " ", vbTextCompare)
            If loc2 > 0 Then
                Cells(r, "A").Characters(Start:=loc1, Length:=Len(w)).Font.Color = vbGreen
                Cells(r, "B").Characters(Start:=loc2, Length:=Len(w)).Font.Color = vbGreen
                ctr = ctr + 1
            End If
        Next w
        Cells(r, "C") = ctr
    Next r
            
End Sub

Note that if you have multiple instances of a word, only the first would be highlighted.

 

[Fluff]

How about

Sub barim()
   Dim Cl As Range
   Dim Sp As Variant
   Dim i As Long, j As Long
   
   For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
      Sp = Split(Cl.Value)
      Cl.Offset(, 1).Font.Color = 0
      Cl.Offset(, 2) = 0
      For i = 0 To UBound(Sp)
         j = InStr(1, Cl.Offset(, 1).Value, Sp(i), vbTextCompare)
         If j > 0 Then
            Cl.Offset(, 1).Characters(j, Len(Sp(i))).Font.Color = vbRed
            Cl.Offset(, 2).Value = Cl.Offset(, 2).Value + 1
         End If
      Next i
   Next Cl
End Sub

 

[CA_Punit]

Sorry is Jumped into the Question without reading it completely.

 

[Fluff]

@CA_Punit
Please post your solution to the board as per the rules. Thanks

 

[CA_Punit]

Hi @Fluff,

Could you please help me with the rule No. so that i don't make mistake in future.

 

[Fluff]

You can find the rules here Message Board Rules
Please post the solution that you came up with.

 

[barim]

Thank you all so much for your help. Both macros are working perfectly and formula is nice too. Only thing that I would like to add to this is that in the case of abbreviations. I have a small list of abbreviations that should be counted as match. For example, "Std" should be "Standard" or "Adpr" should be "Adapter". For the sake of simplicity I would keep list on the same worksheet let's say in Column E. Or it should be a new macro that would go through both columns and find an instances of these abbreviations and correct them before running comparison macro. Whatever is easier. Thanks again and I hope this is not too complicated.

 

[Eric W]

Starting with this:

Book1 (version 1).xlsb
	A	B	C	D	E	F	G
1	Compare1	Compare2	Count Matched Words			Abbreviation	Word
2	Driving Car	Carpet is so useful	0			std	standard
3	Cars are great	Great that we have cars today	2			adpr	adapter
4	Mazda is reliable car	Mazda is good car	3			ltd	limited
5	Walking is good for your health	Health is precious	2			auto	automobile
6	Library is so far away	I live so far away	3
7	This is a standard phrase	My std order	1
8	I have an old auto	my automobile is old	2
9	A big fat orange lazy cat is here	Here lies an orange lazy cat that's big	5
10	It's std to run amok	My standard rule is to save often	2
Sheet25

You can use this variation of my macro:

Sub HiLiteWords()
Dim r As Long, Colors As Variant, Abbr As Variant, MyData As Variant
Dim w1 As String, w2 As String, ws1 As Variant, w As Variant
Dim loc1 As Long, loc2 As Long, ctr As Long, L2 As Long

    Colors = Array(vbGreen, vbRed, vbCyan, vbMagenta, RGB(200, 100, 0))
    Set Abbr = CreateObject("Scripting.Dictionary")
    
    MyData = Range("F2:G" & Cells(Rows.Count, "F").End(xlUp).Row).Value
    For r = 1 To UBound(MyData)
        Abbr(MyData(r, 1)) = MyData(r, 2)
        Abbr(MyData(r, 2)) = MyData(r, 1)
    Next r
    
    For r = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        w1 = Cells(r, "A").Value
        w2 = Cells(r, "B").Value
        ws1 = Split(w1, " ")
        ctr = 0
        For Each w In ws1
            loc1 = InStr(1, " " & w1 & " ", " " & w & " ", vbTextCompare)
            loc2 = InStr(1, " " & w2 & " ", " " & w & " ", vbTextCompare)
            L2 = Len(w)
            If loc2 = 0 Then
                If Abbr.Exists(w) Then
                    loc2 = InStr(1, " " & w2 & " ", " " & Abbr(w) & " ", vbTextCompare)
                    L2 = Len(Abbr(w))
                End If
            End If
            If loc2 > 0 Then
                Cells(r, "A").Characters(Start:=loc1, Length:=Len(w)).Font.Color = Colors(ctr Mod (UBound(Colors) + 1))
                Cells(r, "B").Characters(Start:=loc2, Length:=L2).Font.Color = Colors(ctr Mod (UBound(Colors) + 1))
                ctr = ctr + 1
            End If
        Next w
        Cells(r, "C") = ctr
    Next r
            
End Sub

I got a little cute with the colors. If you don't like the color variations, change this line:

    Colors = Array(vbGreen, vbRed, vbCyan, vbMagenta, RGB(200, 100, 0))

to

    Colors = Array(vbGreen)

using whatever color you prefer.