VBA to Color a Single word (or Phrase) in a large population

[seeja001]

Hello - I'm new to the message board and NOT a programer (but I do naively dabble in VBA a bit). My task is simple: I have many cells in a sheet (~ 1500 lines) that may contain a word AND I want to color the word (or phrase) so as to easily spot it visually when reviewing the sheet. Cell Content varies from 0 < x < 1200 characters. This can be don manually, but it's a real pain. I've used a few routines that when executed, color ALL text contained within the cell rather than isolating the single word of phrase. My latest version modified some example code using a class module approach, but throws compiler errors for the "With/End With" or "For Each" constructs upon execution. Would appreciate any help from the more seasoned folks if possible. Thanks.

Class Module:

Option Explicit
Private pPhrase As String

Private Sub Class_Initialize()
Worksheets("Sheet1").Select
End Sub

Private Sub Class_Terminate()
End Sub

Public Property Let Phrase(Value As String)
pPhrase = Value
End Property

Public Property Get Phrase() As String
Phrase = pPhrase
End Property

Normal Module:

Option Explicit

Sub UsingColorWordClass()
Dim w As ColorWord
Dim r As Range
Set w = New ColorWord
Set r = Range("ab3:ab1500")
w.Phrase = "HOUSE"

'With w
' .Font.Bold = True
' .Font.Color = vbRed
'End With

For Each w In r
w.Color = vbRed
Next

Debug.Print w.Phrase
Set w = Nothing

End Sub

 

[Skyybot]

This is as close as I can get. Make sure to try it on a copy of your Workbook as unexpected results may occur.

Sub Format_Words()


Dim wb As Workbook, sht As Worksheet, rng As Range, cell As Range
Dim fnd As Range, str As Variant, sStr As Variant, srchTxt As String
Set wb = Workbooks("File-45_(M-Test).xlsm") 'Change to name of copy until tested
Set sht = wb.Sheets("Sheet1")
Set rng = sht.Range("AB3:AB1500")
srchTxt = "house"

For Each cell In rng
    sStr = InStr(1, cell.Value, srchTxt, vbTextCompare)
    str = Replace(cell.Value, "house", "house", , , vbTextCompare)
    With cell.Characters(sStr, 5)
        .Font.FontStyle = "Bold"
        .Font.Color = RGB(255, 0, 0)
    End With
Next cell
End Sub

 

[seeja001]

Thank You - I tested the code (unsuccessfully) and the routine registered another Error for the line: str = Replace(cell.Value, "house", "house", , , vbTextCompare); where the word "Replace" was highlighted with the following error stmt;
Compile error:
Wrong number of arguments or invalid property assignment

 

[Peter_SSs]

The code did not error for me. However,

• if the text of interest appeared more than once in a cell it was only highlighted once
• if the text of interest did not appear at all in a cell, other text became highlighted
• if the text of interest was part of a longer word, the text was still highlighted (eg "Household")

I would normally use a regular expression approach for this sort of job but I think with Mac you don't have that option (or at least not as easily). In searching for "words", punctuation can sometimes cause problems. In the code below I have listed some punctuation to 'ignore' to try to help identify "words" rather than just text strings.
This code works on the active sheet. You would have to adjust if looking at a particular worksheet in a particular workbook.

Sub Highlight_Text_of_Interest()
  Dim a As Variant
  Dim i As Long, j As Long, pos As Long, L As Long, st As Long
  Dim s As String, t As String
 
  Const TextOfInterest As String = "Lorem Ipsum"  '<- Your word or phrase
  Const PunctToEliminate As String = ".?'"        '<- Add more if required
 
  t = " " & TextOfInterest & " "
  L = Len(TextOfInterest)
  Application.ScreenUpdating = False
  With Range("AB3", Range("AB" & Rows.Count).End(xlUp))
    .Font.Color = vbBlack
    .Font.Bold = False
    a = .Value
    For i = 1 To UBound(a)
      s = " " & a(i, 1) & " "
      For j = 1 To Len(PunctToEliminate)
        s = Replace(s, Mid(PunctToEliminate, j, 1), " ")
      Next j
      st = 1
      pos = InStr(1, s, t, vbTextCompare)
      Do Until pos = 0
        With .Cells(i).Characters(pos, L)
          .Font.Color = vbRed
          .Font.Bold = True
        End With
        st = pos + L + 1
        pos = InStr(st, s, t, vbTextCompare)
      Loop
    Next i
  End With
  Application.ScreenUpdating = True
End Sub

Here is my sample data ..

seeja001.xlsm
	AB
1
2
3	Lorem Ipsum is simply dummy text of the printing and typesetting industry. Lorem Ipsum has been the industry's standard dummy text ever since the 1500s, when an unknown printer took a galley of type and scrambled it to make a type specimen book. It has survived not only five centuries, but also the leap into electronic typesetting, remaining essentially unchanged. It was popularised in the 1960s with the release of Letraset sheets containing Lorem Ipsum passages, and more recently with desktop publishing software like Aldus PageMaker including versions of Lorem Ipsum.
4	Nothing here
5
6	Lorem Ipsum or lorem ipsum but not Florem ipsums
Sheet3

.. and looking for the phrase "Lorem Ipsum" (but not case-sensitive). Results:

 

[seeja001]

Thank You Peter - ran your revised routine with same unsuspecting result: this time code line was: s = Replace(s, Mid(PunctToEliminate, j, 1), " ") with Replace highlighted.
Compile error:
Wrong number of arguments or invalid property assignment

I truly appreciate your efforts you've been kind enough to afforded me. I'll keep at it. Right now, I'm just baffled!!

 

[Peter_SSs]

The code runs without error for me. I am working within Windows, not MacOS, but I am not aware that could be an issue.

Have you used the entire code exactly as I posted or have you modified it in some way? Is there other vba code in the workbook?

Have you tried it in a new workbook with my sample data copied from the forum (use the below button to copy and then paste into cell AB1 of a new workbook)?

If you make a new line where shown in the code and type s = Replace(
do you get intellisense pop-up like this? Is it different?

 

[seeja001]

Hi Peter_SSs, Finally had some time to look at your suggestions. Yes, I pasted your code into a new module within my file and ran it unsuccessfully as I mentioned last night. I also attempted to code the line s = Replace(s, Mid(PunctToEliminate, j, 1), " ") and the Intellisense DID NOT appear as shown in your reply. Tonight, I followed your suggestion and created a new workbook with a single, new code module and pasted in your code - and viola! success at last! In addition, if I type in the s = Replace(s, Mid(PunctToEliminate, j, 1), " ") in this new module, Intellisense DOES function correctly. I don't understand why having my original file (with a few normal and class modules) didn't execute correctly when I created a new module containing your code. Thank You Peter_SSs, the Efforts are indeed Very Much Appreciated! I'll mark the thread as a solution but would ask if you have any input that I can learn from, I'd love to acquire the educational lesson.

 

[Peter_SSs]

Glad you got the code to work in the end.
Sounds like something in your existing code must have been causing the problem.