VBA: how to sort cell data on the basis Font color

Question

I have a data string in the cell as

I want to sort the string on the basis of Font Color such as

Possible to write in a VBA code. Thanks

Range("S37").Select
ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Add(Range("S37:S37"), _
    xlSortOnFontColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(0, 102 _
    , 0)
With ActiveWorkbook.Worksheets("sheet1").Sort
    .SetRange Range("S37:S37")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

Answer 1

Another version:

Sub GroupNumbersByColor()

    Dim c As Range, c2 As Range, num, pos As Long, txt As String
    Dim dict As Object, clr As Long, k, sep As String, ch As String
    Set dict = CreateObject("scripting.dictionary")
    
    Set c = ActiveSheet.Range("D13") 'for example
    txt = c.Value & " " 'dodge to avoid ending on a digit...
    num = ""
    For pos = 1 To Len(txt)
        ch = Mid(txt, pos, 1)
        If ch Like "#" Then 'numeric?
            clr = c.Characters(pos, 1).Font.Color 'get the font color
            '... assuming all digits of each number share the same font color
            If Not dict.Exists(clr) Then dict.Add clr, New Collection 'new color?
            num = num & ch 'build up the number
        Else
            If Len(num) > 0 Then dict(clr).Add num 'capture previous number
            num = ""
        End If
    Next pos
    
    'write the grouped numbers out to the next column
    Set c2 = c.Offset(0, 1)
    c2.ClearContents
    For Each k In dict           'k=text color
        For Each num In dict(k)  'all numbers for this color
            AppendTextWithColor c2, sep, vbBlack
            AppendTextWithColor c2, CStr(num), CLng(k)
            sep = ","
        Next num
    Next k
End Sub

'Append text to a cell, and set the text's color
Sub AppendTextWithColor(c As Range, txt As String, clr As Long)
    If Len(txt) = 0 Then Exit Sub
    c.Characters(c.Characters.Count + 1, Len(txt)).Insert txt
    c.Characters(c.Characters.Count - (Len(txt) - 1), Len(txt)).Font.Color = clr
End Sub