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>

 

[MickG]

Try This:-

[COLOR="Navy"]Sub[/COLOR] MG12Oct39
[COLOR="Navy"]Dim[/COLOR] Rng             [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn              [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] n               [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic             [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Sp              [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c               [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = ActiveWorkbook.Names("content_checked").RefersToRange
    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng: Dic(Dn.Value) = Empty: [COLOR="Navy"]Next[/COLOR]
             [COLOR="Navy"]With[/COLOR] Sheets("A+_Creation")
                [COLOR="Navy"]Set[/COLOR] Rng = .Range("G15, G19, G21, E30:E6000")
            [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    c = 0
    Sp = Split(Dn.Value, " ")
        [COLOR="Navy"]For[/COLOR] n = 1 To UBound(Sp)
            c = c + Len(Sp(n)) + 1
            [COLOR="Navy"]If[/COLOR] Dic.exists(Sp(n)) [COLOR="Navy"]Then[/COLOR]
                Dn.Characters(c, Len(Sp(n))).Font.Color = vbRed
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Rick Rothstein]

Here is my code that you referenced in your question modified for what I think you described as your setup...

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("G13,G15,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
            Cell.Characters(Position, Len(Words(Z, 1))).Font.ColorIndex = 3  'Red
            Position = InStr(Position + 1, Cell.Value, Words(Z, 1), vbTextCompare)
          Loop
        Next
    End If
  Next
End Sub

 

[western077]

Here is my code that you referenced in your question modified for what I think you described as your setup...

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("G13,G15,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
            Cell.Characters(Position, Len(Words(Z, 1))).Font.ColorIndex = 3  'Red
            Position = InStr(Position + 1, Cell.Value, Words(Z, 1), vbTextCompare)
          Loop
        Next
    End If
  Next
End Sub

This is exactly what I was after and it works brilliantly! Thank you so much!! You just saved a lot of people a ton of time!

 

[MickG]

Code ERROR
Please change this:-

Set rng = ActiveWorkbook.Names("content_checked").RefersToRange

For This:-

Set rng = ActiveWorkbook.Names("content_check").RefersToRange

 

[western077]

Hi MickG,

Thank you for your response. I tried your code as well, but it hasn't worked for me. I assigned the macro to a button, but nothing appears to happen when I click on it as the banned words remain black in the cell.

 

[MickG]

Not to worry, You perhaps have'nt changed the line as per the Reply above !!!!!

 

[imurra]

Hello Rick,

This worked really well for me as well. However how can it be modified to highlight only whole words.

My word list contains names such as Gandhi, To, Ha, Smith, La.

It does find the names in the below, but also subsets of names are highlighted (see below). How can the code be chandes to only find whole words- or words with spaces before or after them?

Gandhi, Jason, Kaplan, Shaffy, Noel L. Smith, and Sardar Ali Khan. “The Molecular Biology of Prostate Cancer: Current Understanding and Clinical Implications.” Prostate Cancer and Prostatic Diseases, December 27, 2017.

I hope that this makes sense? I am very new to VBA.

Cheers
Ian

 

[Rick Rothstein]

Hello Rick,

This worked really well for me as well. However how can it be modified to highlight only whole words.

My word list contains names such as Gandhi, To, Ha, Smith, La.

It does find the names in the below, but also subsets of names are highlighted (see below). How can the code be chandes to only find whole words- or words with spaces before or after them?

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]

 

[imurra]

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

[TABLE="width: 500"]
<tbody>[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]
</tbody>[/TABLE]

It worked wonderfully. I modified it a bit and put in explanations for new users like myself. All credit to Rick Rodstein.
Sub ColorCertainWords()
Dim Z As Long, Position As Long, Words As Variant, Cell As Range
' insert range of list of words to use to search for
Words = Range("d2:d237")
' insert range in which to find words
For Each Cell In Sheets("Sheet1").Range("a2:a318")
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