VBA to Highlight Specific Text

[chingching831]

Hi,

May I know how I can edit the VBA code below so that these 2 criteria can be met?
1. Highlight text that is Case Insensitive
2. Don't highlight text that is embedded within other text


Sub HighlightStrings_CaseSensitive_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 Higlighter")
If TypeName(xHStr) <> "String" Then Exit Sub
Application.ScreenUpdating = False
For Each xCell In Selection
Dim varWord As Variant
For Each varWord In Split(xHStr, Space$(1))
xHStrLen = Len(varWord)
xArr = Split(xCell.Value, 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 = 39
xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Bold = True
xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Italic = True
xStrTmp = xStrTmp & varWord
Next
End If
Next varWord
Next xCell
Application.ScreenUpdating = True
End Sub


Thanks !!

 

[DanteAmor]

Hi and welcome to MrExcel!

Try this:

Sub HighlightStrings_CaseSensitive_NotExactText()
  Dim xHStr As String, xStrTmp As String
  Dim xHStrLen As Long, xCount As Long, I As Long
  Dim xCell As Range
  Dim xArr
  Dim varWord As Variant
  
  'On Error Resume Next
  xHStr = Application.InputBox("What are the words to highlight:", "Word Higlighter")
  If TypeName(xHStr) <> "String" Then Exit Sub

  Application.ScreenUpdating = False
  For Each xCell In Selection
    For Each varWord In Split(xHStr, Space$(1))
      xHStrLen = Len(" " & varWord & " ")
      xArr = Split(" " & xCell.Value & " ", " " & varWord & " ", , vbTextCompare)
      xCount = UBound(xArr)
      If xCount > 0 Then
        xStrTmp = ""
        For I = 0 To xCount - 1
          xStrTmp = xStrTmp & xArr(I)
          xCell.Characters(Len(xStrTmp), xHStrLen - 1).Font.ColorIndex = 39
          xCell.Characters(Len(xStrTmp), xHStrLen - 1).Font.Bold = True
          xCell.Characters(Len(xStrTmp), xHStrLen - 1).Font.Italic = True
          xStrTmp = xStrTmp & " " & varWord & " "
        Next
      End If
    Next varWord
  Next xCell
  Application.ScreenUpdating = True
End Sub

 

[chingching831]

Thanks a lot DanteAmor!! It works well!

If I want to further modify this to highlight multiple text, how should I do it?

Much appreciated

 

[bebo021999]

This for single, multiple text.
There are 2 inputboxes:
- input range (select range first, or manual input)
- textstring input( delimiter by ";" : semi-colon)
for instant:
monkey
or
monkey;world;hello

Option Explicit
Sub test()
Dim i&, k&, ibRng, ibWord, cell As Range, word, arr(1 To 65000, 1 To 100)
ibRng = InputBox("choose range(s) to highlight:", "Hightlight Range(s)", Selection.Address)
'-----------------------------------------
'check if range is valid
If Not Evaluate("ISREF(" & ibRng & ")") Then
    MsgBox "Invalid range!"
    Exit Sub
End If
ibWord = InputBox("Which Word(s) to highlight (use semi-colon for multiple Words:", "Highlight Word(s)")
'check if word is valid
If Len(ibWord) = 0 Then
    MsgBox "pick a word!"
    Exit Sub
End If
If InStr(1, ibWord, ",") > 0 Then
    MsgBox "Use semi-colon!"
    Exit Sub
End If
'-------------------------------------
    For Each cell In Range(ibRng)
        k = 0
        For Each word In Split(ibWord, ";")
            For i = 1 To Len(cell) - Len(word) + 4
                If Mid(" " & Trim(LCase(cell)) & " ", i, Len(word) + 2) = " " & Trim(LCase(word)) & " " Then
                    k = k + 1
                    arr(k, 1) = i: arr(k, 2) = Len(word) + 2
                End If
            Next
        Next
        For i = 1 To k
            With cell.Characters(arr(i, 1) - 1, arr(i, 2) - 1)
                .Font.ColorIndex = 39
                .Font.Bold = True
                .Font.Italic = True
            End With
        Next
    Next
End Sub

 

[DanteAmor]

If I want to further modify this to highlight multiple text, how should I do it?

The macro already works for that, you just have to write the words separated by a space, for example:

Thanks a lot DanteAmor!! It works wel

Im glad to help you, thanks for the feedback.

 

[chingching831]

The macro already works for that, you just have to write the words separated by a space, for example:

View attachment 66204



Im glad to help you, thanks for the feedback.

I am not familiar with macro... that's why not sure how to utilize this

 

[chingching831]

This for single, multiple text.
There are 2 inputboxes:
- input range (select range first, or manual input)
- textstring input( delimiter by ";" : semi-colon)
for instant:
monkey
or
monkey;world;hello

Option Explicit
Sub test()
Dim i&, k&, ibRng, ibWord, cell As Range, word, arr(1 To 65000, 1 To 100)
ibRng = InputBox("choose range(s) to highlight:", "Hightlight Range(s)", Selection.Address)
'-----------------------------------------
'check if range is valid
If Not Evaluate("ISREF(" & ibRng & ")") Then
    MsgBox "Invalid range!"
    Exit Sub
End If
ibWord = InputBox("Which Word(s) to highlight (use semi-colon for multiple Words:", "Highlight Word(s)")
'check if word is valid
If Len(ibWord) = 0 Then
    MsgBox "pick a word!"
    Exit Sub
End If
If InStr(1, ibWord, ",") > 0 Then
    MsgBox "Use semi-colon!"
    Exit Sub
End If
'-------------------------------------
    For Each cell In Range(ibRng)
        k = 0
        For Each word In Split(ibWord, ";")
            For i = 1 To Len(cell) - Len(word) + 4
                If Mid(" " & Trim(LCase(cell)) & " ", i, Len(word) + 2) = " " & Trim(LCase(word)) & " " Then
                    k = k + 1
                    arr(k, 1) = i: arr(k, 2) = Len(word) + 2
                End If
            Next
        Next
        For i = 1 To k
            With cell.Characters(arr(i, 1) - 1, arr(i, 2) - 1)
                .Font.ColorIndex = 39
                .Font.Bold = True
                .Font.Italic = True
            End With
        Next
    Next
End Sub

This is really helpful! But the previous code can use in both English and Chinese languages. May I know what has been changed here as it can only be applied to Eng? Any ways to change it so that the code applies to both languages?

 

[DanteAmor]

I am not familiar with macro... that's why not sure how to utilize this

As I said, when you capture the words you just have to separate them by a space, as in my example.

 

[chingching831]

As I said, when you capture the words you just have to separate them by a space, as in my example.

View attachment 66229

you are right! I just realised it now, thanks a lot!

 

[DanteAmor]

Again with pleasure. Thanks for the feedback.