Excel Macro To Color Certain Words In A Line Of Text

[western077]

Hello,

I currently have a list of banned words which I have named "content_check" and are in a tab called "Guide". I would like to make a macro which will check cells G13, G15, G19, G21 and E30:E6000 (if not blank) in the tab "A+_Creation" and highlight in red any words which match those in the banned words list. These cells can contain up to 1000 characters each and could contain more than 1 banned word.I'm currently using conditional formatting which turns any cells which contain a banned word red, but given that the list has almost 400 words it would be much better if only the word turned red instead of the whole cell. I noticed that something similar has already been covered in this post: http://www.mrexcel.com/forum/excel-...change-font-specific-words-cells-excel-2.html and I tried editing Rick Rothstein's code to match my requirements, but it just crashes when I try to run it. I have good knowledge of formulas, but I'm still quite new to macros and something like this is beyond my technical ability. Would anyone know how to go about this? Any help would be hugely appreciated!

<tbody>
</tbody>

 

[Rick Rothstein]

It worked wonderfully. I modified it a bit and put in explanations for new users like myself.

NOTE: I had to modify the code a slight bit to fix a subtle bug that existed in my original code (so use the code below)

I hope this more fully commented code may prove to be more useful to you as well as to others...

Sub ColorCertainWords()
  Dim Z As Long, Position As Long, Words As Variant, Cell As Range
  ' This should speed the macro up as it allows all the display changes to occur all at once rather than one at a time
  Application.ScreenUpdating = False
  ' Put list of words to check into an array where they can be accessed faster
  Words = Range("D2:D237")
  ' Loop through each cell that needs to be checked
  For Each Cell In Sheets("Sheet1").Range("A2:A318")
    ' Only process the cell if it has text in it
    If Len(Cell.Value) Then
      ' Loop through each word that needs to be checked for
      For Z = 1 To UBound(Words)
        ' If there was no word in the cell, then skip to the word from the next cell
        If Len(Words(Z, 1)) Then
          ' Find the first occurance of that word
          Position = InStr(1, Cell.Value, Words(Z, 1), vbTextCompare)
          ' This loop will execute only if the value of Position is
          ' not zero (zero would mean the word is not in the text)
          Do While Position
            ' We put a character that is not in the word being checked for on each side
            ' of the part of the text in the cell starting at the position of the word
            ' (we do this in case the word occurs at the beginning or end of the text)
            ' and then check to see if that word with a non-letter, non-digit on either
            ' side of it matches the part of the text to the left of the Like operator
            If Mid("_" & Cell.Value, Position) & "_" Like "[!A-Za-z0-9]" & Words(Z, 1) & "[!A-Za-z0-9]*" Then
              ' If the Like operator comparison succeeds,it means the word stands
              ' alone, so we color that word red by using the Character property
              ' to locate the word inside of the text... Position tells us where
              ' it starts and the Len function is used to tell us how many characters
              Cell.Characters(Position, Len(Words(Z, 1))).Font.ColorIndex = 3  'Red
            End If
            ' We next find the position of the word being checked later of in the text
            ' starting our search from one past the currently found position of the word
            Position = InStr(Position + 1, Cell.Value, Words(Z, 1), vbTextCompare)
          Loop
        End If
      Next
    End If
  Next
  Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

Here is another approach to consider. I think it also does what you want. For me it is faster than the previous code though not enough to be of particular benefit. If the list of words to check and/or the number and/or length of sentences increases, the relative speed benefit of this code should increase. The code does assume no blanks in the list in column D (but could be adapted if that is a problem)

Sub HighlightWords()
  Dim RX As Object
  Dim itm As Variant
  Dim c As Range

  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  RX.Pattern = "\b(" & Join(Application.Transpose(Range("D2:D237").Value), "|") & ")\b"
  Application.ScreenUpdating = False
  For Each c In Sheets("Sheet1").Range("A2:A318")
    For Each itm In RX.Execute(c.Value)
      c.Characters(Start:=itm.firstindex + 1, Length:=itm.Length).Font.Color = vbRed
    Next itm
  Next c
  Application.ScreenUpdating = True
End Sub

 

[Ian Werich]

See if this version of my code does what you want...

[table="width: 500"]
[tr]
    [td]Sub ColorCertainWords()
  Dim Z As Long, Position As Long, Words As Variant, Cell As Range
  Words = Range("content_check")
  For Each Cell In Sheets("A+_Creation").Range("G15,G13,G19,G21,E30:E6000")
    If Len(Cell.Value) Then
        For Z = 1 To UBound(Words)
          Position = InStr(1, Cell.Value, Words(Z, 1), vbTextCompare)
          Do While Position
            If "_" & Mid(Cell.Value, Position) & "_" Like "[!A-Za-z0-9]" & Words(Z, 1) & "[!A-Za-z0-9]*" Then
              Cell.Characters(Position, Len(Words(Z, 1))).Font.ColorIndex = 3  'Red
            End If
            Position = InStr(Position + 1, Cell.Value, Words(Z, 1), vbTextCompare)
          Loop
        Next
    End If
  Next
End Sub[/td]
[/tr]
[/table]

Hi, Rick Rothstein,

I really appreciate your answer to Imurra and I'd like ask you if it's possibile to parse a single cell containg a long text (in my case, the words of a song) to highlight in red some special words (these only), which are listed in "content_check", leaving the other words in black.

Thank you in advance!

Ian

 

[Rick Rothstein]

I really appreciate your answer to Imurra and I'd like ask you if it's possible to parse a single cell containing a long text (in my case, the words of a song) to highlight in red some special words (these only), which are listed in "content_check", leaving the other words in black.

Assuming the cell containing the song is cell A1 on Sheet1 and assuming that "content_check" is a Defined Range Name referencing the range where the words you want to highlight are located, here is my code modified to use them (note - I left all of the comments intact)...

Sub ColorCertainWords()
  Dim Z As Long, Position As Long, Words As Variant, Cell As Range
  ' This should speed the macro up as it allows all the display changes to occur all at once rather than one at a time
  Application.ScreenUpdating = False
  ' Put list of words to check into an array where they can be accessed faster
  Words = Range("content_check")
  ' Loop through each cell that needs to be checked
  For Each Cell In Sheets("Sheet1").Range("A1")
    ' Only process the cell if it has text in it
    If Len(Cell.Value) Then
      ' Loop through each word that needs to be checked for
      For Z = 1 To UBound(Words)
        ' If there was no word in the cell, then skip to the word from the next cell
        If Len(Words(Z, 1)) Then
          ' Find the first occurance of that word
          Position = InStr(1, Cell.Value, Words(Z, 1), vbTextCompare)
          ' This loop will execute only if the value of Position is
          ' not zero (zero would mean the word is not in the text)
          Do While Position
            ' We put a character that is not in the word being checked for on each side
            ' of the part of the text in the cell starting at the position of the word
            ' (we do this in case the word occurs at the beginning or end of the text)
            ' and then check to see if that word with a non-letter, non-digit on either
            ' side of it matches the part of the text to the left of the Like operator
            If Mid("_" & Cell.Value, Position) & "_" Like "[!A-Za-z0-9]" & Words(Z, 1) & "[!A-Za-z0-9]*" Then
              ' If the Like operator comparison succeeds,it means the word stands
              ' alone, so we color that word red by using the Character property
              ' to locate the word inside of the text... Position tells us where
              ' it starts and the Len function is used to tell us how many characters
              Cell.Characters(Position, Len(Words(Z, 1))).Font.ColorIndex = 3  'Red
            End If
            ' We next find the position of the word being checked later of in the text
            ' starting our search from one past the currently found position of the word
            Position = InStr(Position + 1, Cell.Value, Words(Z, 1), vbTextCompare)
          Loop
        End If
      Next
    End If
  Next
  Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

parse a single cell containg a long text (in my case, the words of a song) to highlight in red some special words (these only), which are listed in "content_check"

If you are interested in trying it, the adaptation of my code would be as below. I have also assumed that "content_check" is a defined range name (vertical range) with no blank cells in that named range.

Sub HighlightWords()
  Dim itm As Variant
 
  Application.ScreenUpdating = False
  With CreateObject("VBScript.RegExp")
    .Global = True
    .IgnoreCase = True
    .Pattern = "(\b| )(" & Join(Application.Transpose(Range("content_check").Value), "|") & ")(\b| )"
    For Each itm In .Execute(Range("A1").Value)
      Range("A1").Characters(Start:=itm.firstindex + 1, Length:=itm.Length).Font.Color = vbRed
    Next itm
  End With
  Application.ScreenUpdating = True
End Sub

 

[Ian Werich]

Assuming the cell containing the song is cell A1 on Sheet1 and assuming that "content_check" is a Defined Range Name referencing the range where the words you want to highlight are located, here is my code modified to use them (note - I left all of the comments intact)...

Sub ColorCertainWords()
  Dim Z As Long, Position As Long, Words As Variant, Cell As Range
  ' This should speed the macro up as it allows all the display changes to occur all at once rather than one at a time
  Application.ScreenUpdating = False
  ' Put list of words to check into an array where they can be accessed faster
  Words = Range("content_check")
  ' Loop through each cell that needs to be checked
  For Each Cell In Sheets("Sheet1").Range("A1")
    ' Only process the cell if it has text in it
    If Len(Cell.Value) Then
      ' Loop through each word that needs to be checked for
      For Z = 1 To UBound(Words)
        ' If there was no word in the cell, then skip to the word from the next cell
        If Len(Words(Z, 1)) Then
          ' Find the first occurance of that word
          Position = InStr(1, Cell.Value, Words(Z, 1), vbTextCompare)
          ' This loop will execute only if the value of Position is
          ' not zero (zero would mean the word is not in the text)
          Do While Position
            ' We put a character that is not in the word being checked for on each side
            ' of the part of the text in the cell starting at the position of the word
            ' (we do this in case the word occurs at the beginning or end of the text)
            ' and then check to see if that word with a non-letter, non-digit on either
            ' side of it matches the part of the text to the left of the Like operator
            If Mid("_" & Cell.Value, Position) & "_" Like "[!A-Za-z0-9]" & Words(Z, 1) & "[!A-Za-z0-9]*" Then
              ' If the Like operator comparison succeeds,it means the word stands
              ' alone, so we color that word red by using the Character property
              ' to locate the word inside of the text... Position tells us where
              ' it starts and the Len function is used to tell us how many characters
              Cell.Characters(Position, Len(Words(Z, 1))).Font.ColorIndex = 3  'Red
            End If
            ' We next find the position of the word being checked later of in the text
            ' starting our search from one past the currently found position of the word
            Position = InStr(Position + 1, Cell.Value, Words(Z, 1), vbTextCompare)
          Loop
        End If
      Next
    End If
  Next
  Application.ScreenUpdating = True
End Sub

Hi Rick!
Your code works as I need, but only if I don't change the string: For Each Cell In Sheets("Sheet1").Range("A1").
In my case, the range to parse is cell "i4" of sheet "CercaTesto" (content_check is stored in another sheet of the same file containing sheet "CercaTesto").
I've tried to customize your code but it doesn't work, maybe (sure) because I'm not a skilled VBA programmer.
Sincerely
Ian

 

[Rick Rothstein]

Did you change this line of code...

For Each Cell In Sheets("Sheet1").Range("A1")

to this...

For Each Cell In Sheets("CercaTesto ").Range("I4")

If so, then describe "doesn't work" for us.

 

[Ian Werich]

Did you change this line of code...

For Each Cell In Sheets("Sheet1").Range("A1")

to this...

For Each Cell In Sheets("CercaTesto ").Range("I4")

If so, then describe "doesn't work" for us.

I've changed the original line of code with the one you suggest, as I supposed.
"It doesn't work" means that no words related to "content_check" are highlighted in red in range I4.
Maybe should I store "content_check" in the same sheet in which I have to parse the text (sheet "CercaTesto")?
Thank you
Ian

 

[Rick Rothstein]

It looks like I accidentally added two spaces after "CercaTesto"... if you copied my code line directly, modify it by removing those excess spaces and try it again, then let me know if it worked or not.

Also, you might want to try Peter's code in Message #15 to see if it works for you or not.

 

[Peter_SSs]

content_check is stored in another sheet of the same file containing sheet "CercaTesto"

You didn't give us the name of that sheet so for the adaptation of my code I have assumed 'Sheet2' for that named range. The adapted code is

Sub HighlightWords()
  Dim itm As Variant
 
  Application.ScreenUpdating = False
  With CreateObject("VBScript.RegExp")
    .Global = True
    .IgnoreCase = True
    .Pattern = "(\b| )(" & Join(Application.Transpose(Sheets("Sheet2").Range("content_check").Value), "|") & ")(\b| )"
    For Each itm In .Execute(Sheets("CercaTesto").Range("I4").Value)
      Sheets("CercaTesto").Range("I4").Characters(Start:=itm.firstindex + 1, Length:=itm.Length).Font.Color = vbRed
    Next itm
  End With
  Application.ScreenUpdating = True
End Sub

For example, here is my content_check (green cells) ..

Book1
	D
1	Content Check
2	good
3	DANCE
4	rhythm
5	singin'
6	I'd
7
Sheet2

.. and here is the result run over the words of American Pie

Book1
	I
4	A long long time ago I can still remember how That music used to make me smile And I knew if I had my chance That I could make those people dance And maybe they'd be happy for a while But February made me shiver With every paper I'd deliver Bad news on the doorstep I couldn't take one more step I can't remember if I cried When I read about his widowed bride Something touched me deep inside The day the music died So Bye, bye Miss American Pie Drove my Chevy to the levee but the levee was dry And them good ole boys were drinking whiskey and rye Singin' this'll be the day that I die This'll be the day that I die Did you write the book of love And do you have faith in God above If the Bible tells you so? Do you believe in rock and roll? Can music save your mortal soul? And can you teach me how to dance real slow? Well, I know that you're in love with him 'Cause I saw you dancin' in the gym You both kicked off your shoes Man, I dig those rhythm and blues I was a lonely teenage broncin' buck With a pink carnation and a pickup truck But I knew I was out of luck The day the music died I started singin' Bye, bye Miss American Pie Drove my Chevy to the levee but the levee was dry And them good ole boys were drinking whiskey and rye Singin' this'll be the day that I die This'll be the day that I die Now, for ten years we've been on our own And moss grows fat on a rolling stone But, that's not how it used to be When the jester sang for the king and queen In a coat he borrowed from James Dean And a voice that came from you and me Oh and while the king was looking down The jester stole his thorny crown The courtroom was adjourned No verdict was returned And while Lennon read a book on Marx The quartet practiced in the park And we sang dirges in the dark The day the music died We were singin' Bye, bye Miss American Pie Drove my Chevy to the levee but the levee was dry Them good ole boys were drinking whiskey and rye And singin' this'll be the day that I die This'll be the day that I die Helter skelter in a summer swelter The birds flew off with a fallout shelter Eight miles high and falling fast It landed foul on the grass The players tried for a forward pass With the jester on the sidelines in a cast Now the half-time air was sweet perfume While sergeants played a marching tune We all got up to dance Oh, but we never got the chance 'Cause the players tried to take the field The marching band refused to yield Do you recall what was revealed The day the music died? We started singin' Bye, bye Miss American Pie Drove my Chevy to the levee but the levee was dry Them good ole boys were drinking whiskey and rye And singin' this'll be the day that I die This'll be the day that I die Oh, and there we were all in one place A generation lost in space With no time left to start again So come on Jack be nimble, Jack be quick Jack Flash sat on a candlestick 'Cause fire is the devil's only friend Oh and as I watched him on the stage My hands were clenched in fists of rage No angel born in Hell Could break that Satan's spell And as the flames climbed high into the night To light the sacrificial rite I saw Satan laughing with delight The day the music died He was singin' Bye, bye Miss American Pie Drove my Chevy to the levee but the levee was dry Them good ole boys were drinking whiskey and rye Singin' this'll be the day that I die This'll be the day that I die I met a girl who sang the blues And I asked her for some happy news But she just smiled and turned away I went down to the sacred store Where I'd heard the music years before But the man there said the music wouldn't play And in the streets the children screamed The lovers cried, and the poets dreamed But not a word was spoken The church bells all were broken And the three men I admire most The Father, Son, and the Holy Ghost They caught the last train for the coast The day the music died And they were singing Bye, bye Miss American Pie Drove my Chevy to the levee but the levee was dry And them good ole boys were drinking whiskey and rye Singin' this'll be the day that I die This'll be the day that I die They were singing Bye, bye Miss American Pie Drove my Chevy to the levee but the levee was dry Them good ole boys were drinking whiskey and rye Singin' this'll be the day that I die
CercaTesto

#VALUE!