Using multiple font colors for multiple integer values conditionally in one cell in excel-CodePudding

I am looking to write a VBA program that allows to color sort multiple integer values in one single cell in excel. For example, if numbers less than 10 will be red, for numbers in between 10-20 will be green, and numbers greater than 20 will be yellow. But, two integer values may be placed in one cell so it is possible that two numbers have different colors inside that cell. Please help. Thanks.

CodePudding user response：

You did not answer my last clarification question... The above solution assumes that the maximum number of digits for each numbers (they may be more then two) is 3. The numbers must be separated with any separator. The patern involving the second number between parenthesis is also covered. It also assumes that the range to be processed in in "A:A" column. The code can be easily adapted to work on any column:

Sub ColorNubersFontConditionaly()
   Dim sh As Worksheet, lastR As Long, arr, strVal As String, necCol As Long, i As Long, j As Long, nbPos As Long
   
   Set sh = ActiveSheet 'use here your necessary worksheet
   lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last filled cell in column A:A
   For i = 2 To lastR 'iterate between the range cells
        nbPos = 1: strVal = sh.Range("A" & i).Value 'place the cell value in a string
        arr = extrAllNumb(strVal)     'the array of extracted numbers
        If IsArray(arr) Then         
            For j = 0 To UBound(arr)  'process each extracted  number and color it according the mentioned conditions
                nbPos = InStr(nbPos, strVal, arr(j), vbTextCompare)
                If CLng(arr(j)) < 10 Then
                    necCol = vbRed
                ElseIf CLng(arr(j)) >= 10 And CLng(arr(j)) <= 20 Then
                    necCol = vbGreen
                Else
                    necCol = vbYellow
                End If
                sh.Range("A" & i).Characters(nbPos, Len(arr(j))).Font.Color = necCol
                nbPos = nbPos   Len(arr(j))
            Next j
        End If
   Next i
End Sub

Private Function extrAllNumb(strVal As String) As Variant 'it return an array containing all numbers having between 1 and 3 digits
    Dim Res As Object, El, arr, i As Long
    With CreateObject("VBScript.RegExp")
        .Pattern = "(\d{1,3})"
        .Global = True
        If .test(strVal) Then
            Set Res = .Execute(strVal)
            ReDim arr(Res.count - 1)
            For Each El In Res
                arr(i) = El: i = i   1
            Next
        End If
    End With
    extrAllNumb = arr
End Function
...
Please, send some feedback after testing the code.