VBA to highlight non-English characters in one go based on RGB Color Code

[chingching831]

Hi all,

I am using the below VBA Code to highlight non-English characters. I have quite a lot of text to highlight, and I want them to be highlighted in different colours. Thus, it's a bit time consuming to use the below code. How can I modify it so that I can highlight a number of text in one go with different colours based on the RGB Code?
e.g.
c1 = RGB(255, 0, 0) 'red
c2 = RGB(255, 204, 0) 'yellow
c3 = RGB(0, 0, 255) 'blue

highlight text in red: "蜘蛛侠"
highlight text in yellow: "纵横宇宙"
highlight text in blue: "动画"

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,
SC

 

[Fuji]

Do you just want to color the non English characters?

Sub test()
    Dim r As Range, m As Object, myColor, n&, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Selection.Font.ColorIndex = xlAutomatic
    myColor = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, _
                16, 17, 18, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, _
                31, 32, 33, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 54, 56)
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "[^\u0030-\u007E]+"
        For Each r In Selection
            For Each m In .Execute(r)
                If Not dic.exists(m.Value) Then
                    dic(m.Value) = n
                    n = n + 1
                    If n > UBound(myColor) Then n = 0
                End If
                r.Characters(m.firstindex + 1, m.Length).Font.ColorIndex = myColor(dic(m.Value))
            Next
        Next
    End With
End Sub

 

[chingching831]

Do you just want to color the non English characters?

Sub test()
    Dim r As Range, m As Object, myColor, n&, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Selection.Font.ColorIndex = xlAutomatic
    myColor = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, _
                16, 17, 18, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, _
                31, 32, 33, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 54, 56)
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "[^\u0030-\u007E]+"
        For Each r In Selection
            For Each m In .Execute(r)
                If Not dic.exists(m.Value) Then
                    dic(m.Value) = n
                    n = n + 1
                    If n > UBound(myColor) Then n = 0
                End If
                r.Characters(m.firstindex + 1, m.Length).Font.ColorIndex = myColor(dic(m.Value))
            Next
        Next
    End With
End Sub

Not really, but the code I mentioned allows me to highlight simplified chinese characters, which I found many other VBA code couldn't.

 

[Fuji]

I don't know about "simplified chinese characters",
change

        .Pattern = "[^\u0030-\u007E]+"

to

        .Pattern = "[\u4E00-\u9FFF\u6300-\u77FF\u7800-\u8CFF\u8D00-\u9FFF]+"

And see how it goes.

 

[chingching831]

I don't know about "simplified chinese characters",
change

        .Pattern = "[^\u0030-\u007E]+"

to

        .Pattern = "[\u4E00-\u9FFF\u6300-\u77FF\u7800-\u8CFF\u8D00-\u9FFF]+"

And see how it goes.

It can highlight all the text in every cell. How can I highlight specific text instead? If possible, I want a specific color for each specific text?

 

[Fuji]

Then you will need to prepare complete list of the string and corresponding color code somewhere in the worksheet.
Assuming you have Worksheeet named MyList, String in Col. A and color code in Col.B.

Sub test()
    Dim a, i As Long, myList, r As Range, m As Object, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    myList = Sheets("mylist").[a1].CurrentRegion.Value
    For i = 1 To UBound(myList, 1)
        dic(myList(i, 1)) = myList(i, 2)
    Next
    Selection.Font.Bold = False
    Selection.Font.ColorIndex = xlAutomatic
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = Join(dic.keys, "|")
        For Each r In Selection
            For Each m In .Execute(r)
                r.Characters(m.firstindex + 1, m.Length).Font.ColorIndex = dic(m.Value)
                r.Characters(m.firstindex + 1, m.Length).Font.Bold = True
            Next
        Next
    End With
End Sub

 

[chingching831]

Then you will need to prepare complete list of the string and corresponding color code somewhere in the worksheet.
Assuming you have Worksheeet named MyList, String in Col. A and color code in Col.B.

Sub test()
    Dim a, i As Long, myList, r As Range, m As Object, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    myList = Sheets("mylist").[a1].CurrentRegion.Value
    For i = 1 To UBound(myList, 1)
        dic(myList(i, 1)) = myList(i, 2)
    Next
    Selection.Font.Bold = False
    Selection.Font.ColorIndex = xlAutomatic
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = Join(dic.keys, "|")
        For Each r In Selection
            For Each m In .Execute(r)
                r.Characters(m.firstindex + 1, m.Length).Font.ColorIndex = dic(m.Value)
                r.Characters(m.firstindex + 1, m.Length).Font.Bold = True
            Next
        Next
    End With
End Sub

It successfully highlights the specific text, but I tried multiple times and that the excel becomes not responding after running the code.

 

[Fuji]

That is most probably your string list.
If this doesn't work, need to see your list.

Sub test()
    Dim a, s, i As Long, myList, r As Range, m As Object, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    myList = Sheets("mylist").[a1].CurrentRegion.Value
    For i = 1 To UBound(myList, 1)
        dic(myList(i, 1)) = myList(i, 2)
    Next
    Selection.Font.Bold = False
    Selection.Font.ColorIndex = xlAutomatic
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "([$()^|\\\{}\[\]+*?.-])"
        s = Replace(.Replace(Join(dic.keys, Chr(2)), "\$1"), Chr(2), "|")
        .Pattern = s
        For Each r In Selection
            For Each m In .Execute(r)
                r.Characters(m.firstindex + 1, m.Length).Font.ColorIndex = dic(m.Value)
                r.Characters(m.firstindex + 1, m.Length).Font.Bold = True
            Next
        Next
    End With
End Sub

 

[chingching831]

It seems that my data is too huge, it works perfectly now after I reduce the dataset! Thanks much!

 

[Fuji]

It seems that my data is too huge, it works perfectly now after I reduce the dataset! Thanks much!

Sub testV2()
    Dim myList, e, i&, r As Range, x&, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    myList = Sheets("mylist").[a1].CurrentRegion.Value
    For i = 1 To UBound(myList, 1)
        dic(myList(i, 1)) = myList(i, 2)
    Next
    With Selection
        .Font.Bold = False
        .Font.ColorIndex = xlAutomatic
        For Each r In .Cells
            For Each e In dic
                x = InStr(1, r, e, 1)
                Do While x
                    With r.Characters(x, Len(e)).Font
                        .ColorIndex = dic(e)
                        .Bold = True
                    End With
                    x = InStr(x + 1, r, e, 1)
                Loop
            Next
        Next
    End With
End Sub