Highlight words in cells with VBA.

Highlight words in cells with VBA.

Ever wanted to highlight words within text similar to how most web-browsers will now highlight?  

Browser highlight

Now you can do the same in excel.  Note that this only works on static text, and not on text generated by formulas.

Here's an example of it in action , some generic text - imagine you had to highlight every instance of the word 'fox' in the below range, it'd be pretty labour intensive right?

Highlight Text Example 1Not any more, assigned to a button or within another sub, it's easy to make all your foxes red :
Highlight Text Example 2

 Included in the sub are options to set colour by RGB, and case sensitivity, (you may not want to highlight uppercase , or only title case etc. ). 

It will also find words within words , like  so :

Highlight Text Example 3to 

Highlight Text Example 4Usage - here the user is propted to provide the word, in this example it's set to case-insensitive ,and all words are highlighted a medium burgundy colour.

This example uses a ribbon control, but could also be applied to a button/shape in a workbook instead.



Sub HighLightWord(control As IRibbonControl)

Dim Myword As String

Myword = InputBox("Word to highlight:", "Highlight words")

Call HighlightWords(Selection, Myword, False, 190, 50, 50)

End Sub

Vb

Full code.


Sub HighlightWords(MyRange As Range, Myword As String, Optional bCase As Boolean = False, Optional cRed As Integer = 255, Optional cGreen As Integer = 50, Optional cBlue As Integer = 15)

Dim MyCell As Range, MyLen As Integer, MyStart, bIsFound As Boolean, MyWordCount As Integer, StrLoop As Integer, MyCursor As Integer


MyLen = Len(Myword) ' :: GET CHARACTER LENGTH OF WORD STRING ::

':: OUTER LOOP  -  ITERATE EACH CELL IN RANGE ::
For Each MyCell In MyRange


If bCase = True Then
MyStart = InStr(1, MyCell.text, Myword, vbTextCompare)  ' :: START INDEX WHERE FIRST WORD IS FOUND - CASE SENSITIVE ::
Else
MyStart = InStr(1, UCase(MyCell.text), UCase(Myword), vbTextCompare)  ' :: START INDEX WHERE FIRST WORD IS FOUND - CASE INSENSITIVE ::
End If

If bCase = True Then
MyWordCount = (Len(MyCell.text) - Len(Replace(MyCell.text, Myword, "", 1))) / MyLen  '  :: COUNT OF WORDS IN STRING - CASE SENSITIVE ::
Else
MyWordCount = (Len(MyCell.text) - Len(Replace(UCase(MyCell.text), UCase(Myword), "", 1))) / MyLen  '  :: COUNT OF WORDS IN STRING - CASE INSENSITIVE ::
End If
If MyStart < 0 Then GoTo tNextCell '::  SKIP INNER LOOP IF WORD NOT FOUND ::

MyCursor = MyStart  ':: SET INITIAL CURSOR POSITION ::

For StrLoop = 1 To MyWordCount  ':: INNER LOOP  - ITERATE THROUGH EACH INSTANCE OF WORD IN STRING ::

MyCell.Characters(MyCursor, MyLen).Font.Color = RGB(cRed, cGreen, cBlue)  ' :: APPLY HIGHLIGHT ::
MyCell.Characters(MyCursor, MyLen).Font.Bold = True  ' :: APPLY BOLD ::
'MyCell.offset(0, StrLoop).FormulaR1C1 = "" & MyCursor ':: DEBUG :: '

MyCursor = InStr(MyCursor + MyLen, MyCell.text, Myword, vbTextCompare) ':: SKIP CURSOR POSITION TO NEXT INSTANCE

Next StrLoop

tNextCell:

Next MyCell

End Sub

Vb

 

 As always, it should be mentioned with anything involving looping through ranges, beware of selecting an  entire workbook by mistake.. 

error too many cells to loop!