Highlighting different, multiple words in a cell range by making them Bold and Coloured.

[DataQuestioner]

This is a request to Rick Rothstein and Peter_SSs who created the following VBA script in another Thread to do with underlining key words in a cell range >

I'm looking for a similar solution except I would like the "Words" sheet "Data" to be converted to Bold and Red text.
My Sheet with the cell range to be searched is called "SearchText" and the contents will always be in Column "A".
My Sheet with the words to be searched is called "SearchWords".




Sub UnderlineKeyWords_v2()
Dim AllMatches As Object
Dim itm As Variant, KeyWords As Variant, Keyword As Variant, Data As Variant
Dim tmp(1 To 2000) As Long
Dim DataRng As Range
Dim s As String
Dim i As Long, j As Long, k As Long

Const DataSht As String = "Data" '<- Name of sheet where underlining is done
Const myCol As String = "K" '<- Column of interest on DataSht

Application.ScreenUpdating = False
With Sheets("Words")
KeyWords = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)).Value
End With
For i = 1 To UBound(KeyWords, 1)
KeyWords(i, 1) = "\b" & KeyWords(i, 1) & "\b"
Next i
With Sheets(DataSht)
.Columns(myCol).Font.Underline = False
Set DataRng = .Range(myCol & 1, .Range(myCol & .Rows.Count).End(xlUp))
End With
Data = DataRng.Value
With CreateObject("VBScript.RegExp")
.Global = True
.IgnoreCase = True
For i = 1 To UBound(Data, 1)
Erase tmp
s = Data(i, 1)
k = -1
For Each Keyword In KeyWords


.Pattern = Keyword
Set AllMatches = .Execute(s)
For Each itm In AllMatches
k = k + 2
tmp(k) = itm.firstIndex + 1
tmp(k + 1) = itm.Length
Next itm
Next Keyword
With DataRng.Cells(i)
For j = 1 To k Step 2
.Characters(tmp(j), tmp(j + 1)).Font.Underline = True
Next j
End With
Next i
End With
Application.ScreenUpdating = True
End Sub

 

[DataQuestioner]

Rick or Peter,
Can you modify the above VBA code to include my request?
Thanks.

 

[Rick Rothstein]

Rick or Peter,
Can you modify the above VBA code to include my request?

The words you want to find and make bole and red... are this stand-alone words like the kind in the thread you and I were recently involved it or is this a "highlight the text wherever it may be" request?

 

[DataQuestioner]

The words you want to find and make bole and red... are this stand-alone words like the kind in the thread you and I were recently involved it or is this a "highlight the text wherever it may be" request?

Standalone words with case sensitivity, and hyphenated, and possessive words with apostrophes.

 

[Rick Rothstein]

Standalone words with case sensitivity, and hyphenated, and possessive words with apostrophes.

I'll look at it later when I get a chance, but my gut tells me any such solution will be SLOW, so be prepared for that.

 

[InaCell]

Hi DataQuestioner,

Does the following work?

Sub BoldRedKeyWords()Dim AllMatches As Object
Dim itm As Variant, KeyWords As Variant, Keyword As Variant, Data As Variant
Dim tmp(1 To 2000) As Long
Dim DataRng As Range
Dim WordsRng As Range
Dim s As String
Dim i As Long, j As Long, k As Long


Const DataSht As String = "SearchText" '<- Name of sheet where underlining is done
Const myCol As String = "A" '<- Column of interest on DataSht


Application.ScreenUpdating = False
With Sheets("SearchWords")
KeyWords = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)).Value
End With
For i = 1 To UBound(KeyWords, 1)
KeyWords(i, 1) = "\b" & KeyWords(i, 1) & "\b"
Next i
With Sheets(DataSht)
.Columns(myCol).Font.Bold = False
.Columns(myCol).Font.ColorIndex = 1
Set DataRng = .Range(myCol & 1, .Range(myCol & .Rows.Count).End(xlUp))
End With
Data = DataRng.Value
With CreateObject("VBScript.RegExp")
.Global = True
.IgnoreCase = False
For i = 1 To UBound(Data, 1)
Erase tmp
s = Data(i, 1)
k = -1
For Each Keyword In KeyWords




.Pattern = Keyword
Set AllMatches = .Execute(s)
For Each itm In AllMatches
k = k + 2
tmp(k) = itm.firstIndex + 1
tmp(k + 1) = itm.Length
Next itm
Next Keyword
With DataRng.Cells(i)
For j = 1 To k Step 2
.Characters(tmp(j), tmp(j + 1)).Font.Bold = True
.Characters(tmp(j), tmp(j + 1)).Font.ColorIndex = 3
Next j


End With
Next i
End With
Application.ScreenUpdating = True
End Sub

InaCell.

 

[DataQuestioner]

InaCell,
Thanks for your reply.

The "Dim AllMatches As Object" text needed to be added on a separate line, otherwise the "Sub" title doesn't appear in the ALT+F8 Macro list.

Also, from a functional point of view, the Sub is not differentiating hyphenated words, i.e. a hyphenated word such as "up-hill" ... if the word search was "hill" then up-hill should NOT be highlighted. Only the exact case sensitive condition "hill" should be bold red.

 

[DataQuestioner]

InaCell,
Also, words with a singular possessive apostrophe, i.e. "son's" are not functioning correctly.
If the word search was "son" and the search text in A1 had "son, Son, son's, sons' or sons" then it shouldn't higlight the son portion within "son's", which is what it is currently doing.

 

[DataQuestioner]

I'll look at it later when I get a chance, but my gut tells me any such solution will be SLOW, so be prepared for that.

I'm certain that you're correct re the SLOW activity.
I've already tried "InaCell's" version in post #6, on a modest 10,000 cell range, and it took over 2 minutes to search and highlight only two words in the "SearchWords" Sheet.

Here's hoping that you can work your magic, Rick.

 

[DataQuestioner]

BUMP

Any suggestions, Rick?