Sub Swap(a, x, y)
    Dim i
    Dim t
    ReDim t(LBound(a, 1) To UBound(a, 1))
    For i = LBound(a, 1) To UBound(a, 1)
        t(i) = a(i, x)
    Next
    For i = LBound(a, 1) To UBound(a, 1)
        a(i, x) = a(i, y)
    Next
    For i = LBound(a, 1) To UBound(a, 1)
        a(i, y) = t(i)
    Next
End Sub

Sub Sort(a, row, keys As Scripting.Dictionary)
    Dim i
    Dim j
    For i = LBound(a, 1) To UBound(a, 1) - 1
        For j = LBound(a, 1) To UBound(a, 1) - 1
            If keys(a(row, j)) < keys(a(row, j + 1)) Then
                Call Swap(a, j, j + 1)
            End If
        Next
    Next
End Sub

Function GetSheet(rowNum As Long) As Excel.Worksheet
    Set GetSheet = Excel.Worksheets(rowNum + 1)
End Function

Function GetRels_2(sh As Excel.Worksheet, c As String) As Scripting.Dictionary
    Dim r As Scripting.Dictionary
    Set r = New Scripting.Dictionary
    Dim j As Long
    Dim i As Excel.Range
    For Each i In sh.Range("B1:D1").Columns
        If i.Value = c Then
            j = i.Column
            Exit For
        End If
    Next
    For Each i In sh.Range("A2:D4").Rows
        Call r.Add(i.Columns(1).Value, i.Columns(j))
    Next
    Set GetRels_2 = r
End Function

Function GetRels(rowNum As Long, c As String) As Scripting.Dictionary
    Set GetRels = GetRels_2(GetSheet(rowNum), c)
End Function

Function GetColor(r As Long) As Long
    If r = 5 Then
        GetColor = RGB(255, 0, 0)
    ElseIf r = 3 Then
        GetColor = RGB(255, 128, 128)
    ElseIf r = 1 Then
        GetColor = RGB(255, 192, 192)
    ElseIf r = 0 Then
        GetColor = RGB(255, 224, 224)
    Else
        Call Err.Raise(1, "invalid relative")
    End If
End Function

Function GetColors_2(rels As Scripting.Dictionary) As Scripting.Dictionary
    Dim c As Scripting.Dictionary
    Set c = New Scripting.Dictionary
    Dim i
    For Each i In rels.keys
        Call c.Add(i, GetColor(rels(i)))
    Next
    Set GetColors_2 = c
End Function

Function GetColors(rowNum As Long, c As String) As Scripting.Dictionary
    Set GetColors = GetColors_2(GetRels(rowNum, c))
End Function

Sub Main()
    Dim rowNum As Long
    Dim char1 As String
    rowNum = Excel.Selection.row
    char1 = Excel.Selection.Value
    
    ' Sort
    Dim v As Variant
    Dim sh1 As Excel.Worksheet
    Dim range1 As Excel.Range
    Set sh1 = Excel.Worksheets(1)
    Set range1 = sh1.Range("A1:C3")
    v = range1.Value
    Call Sort(v, 1, GetRels(rowNum, char1))
    range1.Value = v
    
    ' Coloring
    Dim c As Scripting.Dictionary
    Dim i As Excel.Range
    Dim j As Excel.Range
    Dim colNum As Long
    colNum = 1
    For Each i In range1.Rows(rowNum).Columns
        If i.Value = char1 Then
            Exit For
        End If
        colNum = colNum + 1
    Next
    For Each i In range1.Rows
        Set c = GetColors(i.row, i.Columns(colNum).Value)
        For Each j In i.Columns
            j.Interior.Color = c(j.Value)
        Next
    Next
End Sub