chingching831
New Member
- Joined
- Jun 2, 2022
- Messages
- 30
- Office Version
- 2019
- Platform
- Windows
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
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