VBA - Highlight specific key words

[Cruiser69]

Hi all.

I use the following code to highlight in red, certain keywords which appear in a sheet.
There are many more, but I have just shortened it for this purpose.
It works well, but it will highlight anything which contains the word e.g TEA
Like STEAM MOP.
Or BOOKCASE and not just BOOK

Is there a way to just highlight the specific word I have in the Comments

Dim ws As Worksheet

Dim Match As Range

Dim Comment() As String

Set ws = ActiveWorkbook.Worksheets(1)

ReDim Comment(3)

Comment(0) = "TEA"

Comment(1) = "COFFEE"

Comment(2) = "BOOK"



For i = LBound(Comment) To UBound(Comment)

Set Match = ws.Cells.Find(What:=Comment(i), LookIn:=xlValues, _

LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _

MatchCase:=False, SearchFormat:=False)



If Not Match Is Nothing Then

FirstAddress = Match.Address

Do

sPos = InStr(1, Match.Value, Comment(i))

sLen = Len(Comment(i))

Match.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0) ‘Red

Match.Interior.Color = RGB(153, 255, 153) 'Green

Set Match = ws.Cells.FindNext(Match)

Loop While Not Match Is Nothing And Match.Address <> FirstAddress

End If

Next

Thanks for looking

Regards,

Graham

 

[Cruiser69]

Hi Dave.

I tried it again with just a few rows of text and it works perfectly.

The sheet I use normally has between 500 & 2500 rows of text.

I think that is why it is taking so long.

Thanks for you help though.

Regards,

Graham

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. If you want to speed things up, just set your range instead of searching all the cells of the sheet (your code) or the used range (previous code). This code determines the row range based on the last row with a value in "A". It determines the column range based on the last column to the left that is used in row 1. These can be changed as needed (see code comments). HTH. Dave

Sub test()
Dim ws As Worksheet
Dim Rng As Range
Dim Comment As Variant
Dim MyRng As Range, LastRow As Integer, LastCol As Integer
Set ws = ActiveWorkbook.Worksheets(1)
'set search area based on data in "A" row 1
With ws
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row 'change "A" to column
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'change 1 to row#
Set MyRng = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
Comment = Array("TEA", "COFFEE", "BOOK")
On Error GoTo ErFix
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual

For Each Rng In MyRng
If Rng.Text <> vbNullString Then
For i = LBound(Comment) To UBound(Comment)
If LCase(Rng.Text) = LCase(Comment(i)) Then
Rng.Interior.Color = RGB(153, 255, 153) 'Green
End If
Next i
End If
Next Rng
ErFix:
If Err.Number <> 0 Then
MsgBox "Error"
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
End Sub

 

[Cruiser69]

Hi Dave.

Thanks for all your help.

This is the one I went with in the end from Jindon at the Excel Forum

Sub test()
    Dim myComment, a, i As Long, ii As Long, ws As Worksheet
    Dim RegX As Object, m As Object
    Set RegX = CreateObject("VBScript.RegExp")
    myComment = Join(Array("TEA", "COFFEE", "BOOK"), Chr(2))
    With RegX
        .Global = True
        .Pattern = "([$()\\\|\[\]{}*+?.-])"
        myComment = Replace(.Replace(myComment, "\$1"), Chr(2), "|")
        .Pattern = "\b(" & myComment & ")\b"
    End With
    For Each ws In Worksheets
        With ws.Range("a1", ws.Cells.SpecialCells(11)(2))
            .Font.ColorIndex = xlAutomatic
            [B].Font.Bold = False[/B]
            .Interior.ColorIndex = xlNone
            a = .Value
            For i = 1 To UBound(a, 1)
                For ii = 1 To UBound(a, 2)
                    If RegX.test(a(i, ii)) Then
                        [B].Cells(i, ii).Interior.Color = vbGreen[/B]
                        For Each m In RegX.Execute(a(i, ii))
                            .Cells(i, ii).Characters(m.firstindex + 1, m.Length).Font.Color = vbRed
                            [B].Cells(i, ii).Characters(m.firstindex + 1, m.Length).Font.Bold = True[/B]
                        Next
                    End If
                Next
            Next
        End With
    Next
End Sub

Regards,

Graham

 

[NdNoviceHlp]

Thanks for posting your outcome. Have a nice day. Dave