VBA to Highlight Specific Phrase

[chingching831]

Hi there,

I am currently using the VBA code below to highlight specific text in a cell. However, it doesn't allow me to highlight a phrase with spacing in between (e.g. "live tour"). May I know how can I change the VBA so that I can highlight a phrase instead?


Sub HighlightStrings_CaseInsensitive_AllowForeignText_NotExactText()
Dim xHStr As String, xStrTmp As String
Dim xHStrLen As Long, xCount As Long, I As Long
Dim xCell As Range
Dim xArr

On Error Resume Next
xHStr = Application.InputBox("What are the words to highlight:", "Word Highlighter")
If TypeName(xHStr) <> "String" Then Exit Sub

Application.ScreenUpdating = Fals5
For Each xCell In Selection
Dim varWord As Variant
For Each varWord In Split(xHStr, Space$(1))
xHStrLen = Len(varWord)
xArr = Split(LCase(xCell.Value), LCase(varWord))
xCount = UBound(xArr)
If xCount > 0 Then
xStrTmp = ""
For I = 0 To xCount - 1
xStrTmp = xStrTmp & xArr(I)
xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Bold = True
xStrTmp = xStrTmp & varWord
Next
End If
Next varWord
Next xCell
Application.ScreenUpdating = True
End Sub

Thanks,
Samantha

 

[Akuini]

Try this:

Sub chingching831_1()
Dim xFind As String
Dim regEx As Object, Matches As Object, M
Dim c As Range

xFind = Application.InputBox("What are the words to highlight:", "Word Highlighter", Type:=2)
If xFind = "" Then Exit Sub
Application.ScreenUpdating = False
        Set regEx = CreateObject("VBScript.RegExp")
        With regEx
                .Global = True
                .Pattern = "\b" & xFind & "\b"
            For Each c In Selection
                If .test(c) Then
                       Set Matches = .Execute(c)
                    For Each M In Matches
                         c.Characters(M.FirstIndex + 1, M.Length).Font.ColorIndex = 3
                         c.Characters(M.FirstIndex + 1, M.Length).Font.Bold = True
                    Next M
                End If
            Next
        End With
Application.ScreenUpdating = True
End Sub

 

[chingching831]

Try this:

Sub chingching831_1()
Dim xFind As String
Dim regEx As Object, Matches As Object, M
Dim c As Range

xFind = Application.InputBox("What are the words to highlight:", "Word Highlighter", Type:=2)
If xFind = "" Then Exit Sub
Application.ScreenUpdating = False
        Set regEx = CreateObject("VBScript.RegExp")
        With regEx
                .Global = True
                .Pattern = "\b" & xFind & "\b"
            For Each c In Selection
                If .test(c) Then
                       Set Matches = .Execute(c)
                    For Each M In Matches
                         c.Characters(M.FirstIndex + 1, M.Length).Font.ColorIndex = 3
                         c.Characters(M.FirstIndex + 1, M.Length).Font.Bold = True
                    Next M
                End If
            Next
        End With
Application.ScreenUpdating = True
End Sub

Works well, lots of thanks!

 

[Akuini]

You're welcome, glad to help & thanks for the feedback.

 

[smozgur]

Works well, lots of thanks!

The marked solution has been changed accordingly. In your future questions, please mark the post as the solution that actually answered your question, instead of your feedback message as it will help future readers. No further action is required for this thread.