Sub TestColorSort()
 
    Dim rngSortOrder    As Range
 
    Dim rngSortValues   As Range
 
 
 
    '---------------------------------------------------------------------------

    'Change the following ranges as per your requirement

    Set rngSortOrder = Sheet1.Range("A2:A4")
 
    Set rngSortValues = Sheet1.Range("E2:E7")
 
    '===========================================================================

 
 
    Call SetColorIndexOnSortOrder(rngSortOrder)
 
 
 
    Call SplitDeSpiltColorIndex(rngSortOrder, rngSortValues, True)
 
    rngSortOrder.Value = vbNullString
 
 
 
    'Source URL: http://excelexperts.com/sort-n-no-fields-vba

    Call CustomSort(Sheet1.Range("E1:G7"), True, 1) 'Change as per requirement

 
 
    Call SplitDeSpiltColorIndex(rngSortOrder, rngSortValues, False)
 
 
 
    Set rngSortOrder = Nothing
 
    Set rngSortValues = Nothing
 
End Sub
 
 
 
Sub SetColorIndexOnSortOrder(rng As Range)
 
    Dim rngEach As Range
 
 
 
    For Each rngEach In rng
 
        rngEach.Value = rngEach.Interior.Color
 
    Next rngEach
 
 
 
    Set rngEach = Nothing
 
End Sub
 
 
 
Sub SplitDeSpiltColorIndex(rngSortOrder As Range, rngSortValues As Range, blnConcatenate As Boolean)
 
    Dim rngEach As Range
 
    Dim arr
 
    Dim intX As Integer
 
    Dim intIncr As Integer
 
 
 
    intIncr = 1
 
    If blnConcatenate = True Then
 
        For Each rngEach In rngSortValues.Cells
 
            On Error Resume Next
 
            rngEach.Value = Application.WorksheetFunction.Match(rngEach.Interior.Color, rngSortOrder, 0) & "-" & rngEach.Value
 
            If Err.Number <> 0 Then
 
                rngEach.Value = rngSortOrder.Cells.Count + intIncr & "-" & rngEach.Value
 
                intIncr = intIncr + 1
 
            End If
 
            On Error GoTo 0
 
        Next rngEach
 
        Set rngEach = Nothing
 
    Else
 
        arr = rngSortValues
 
        For intX = LBound(arr, 1) To UBound(arr, 1)
 
            arr(intX, 1) = Mid(arr(intX, 1), InStr(arr(intX, 1), "-") + 1)
 
        Next intX
 
        rngSortValues = arr
 
    End If
 
End Sub
 
 
 
Sub CustomSort(rngSortWithHeader As Range, blnSortAscending As Boolean, ParamArray arrFlds() As Variant)
 
'Source URL: http://excelexperts.com/sort-n-no-fields-vba

 
 
    'Parameters

    'rngSortWithHeader      - range including header

    'blnSortAscending       - sort order of all fields; its same for all fields

    'ParamArray arrFlds()   - field names inclosed in "" or column index separated by comma

 
 
    Dim wks         As Worksheet
 
    Dim rngHeader   As Range
 
    Dim rngRef      As Range
 
    Dim rngSortFld  As Range
 
    Dim x           As Integer
 
 
 
    Set wks = rngSortWithHeader.Parent
 
    Set rngHeader = rngSortWithHeader.Rows(1)
 
    With rngSortWithHeader
 
        Set rngRef = Intersect(.Columns(1), .Columns(1).Offset(1))
 
    End With
 
    wks.Sort.SortFields.Clear
 
    For x = LBound(arrFlds) To UBound(arrFlds)
 
        On Error Resume Next
 
            Set rngSortFld = Nothing
 
            Set rngSortFld = rngRef.Offset(, Application.WorksheetFunction.Match(arrFlds(x), rngHeader, 0) - 1)
 
        On Error GoTo 0
 
        If rngSortFld Is Nothing Then
 
            Set rngSortFld = rngRef.Offset(, arrFlds(x) - 1)
 
        End If
 
        If blnSortAscending Then
 
            wks.Sort.SortFields.Add Key:=rngSortFld _
 
                , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 
        Else
 
            wks.Sort.SortFields.Add Key:=rngSortFld _
 
                , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
 
        End If
 
    Next x
 
    With wks.Sort
 
        .SetRange rngSortWithHeader
 
        .Header = xlYes
 
        .MatchCase = False
 
        .Orientation = xlTopToBottom
 
        .SortMethod = xlPinYin
 
        .Apply
 
    End With
 
 
 
    Set wks = Nothing
 
    Set rngHeader = Nothing
 
    Set rngRef = Nothing
 
    Set rngSortFld = Nothing
 
End Sub