Following piece of code sort the data based on custom sort order. You can provide your own sort order in a separate table. For illustration, download the attached file.

Sub TestCustomSort()

    Dim rngSortOrder    As Range

    Dim rngSortValues   As Range

    Dim arrSortOrder

    '---------------------------------------------------------------------------

    'Change the following ranges as per you requirement

    Set rngSortOrder = rngCurRegionFromTopLeft(Sheet1.Range("A1")) 'A1:B4

    Set rngSortValues = rngCurRegionFromTopLeft(Sheet1.Range("E1")).Columns(1) 'E1:E7

    '===========================================================================

    arrSortOrder = rngSortOrder

    Call SplitDeSpiltOrderNum(arrSortOrder, rngSortValues, True)

    'Source URL: http://excelexperts.com/sort-n-no-fields-vba

    Call CustomSort(rngCurRegionFromTopLeft(Sheet1.Range("E1")), True, 1) 'E1:G7

    Call SplitDeSpiltOrderNum(arrSortOrder, rngSortValues, False)

    Set rngSortOrder = Nothing

    Set rngSortValues = Nothing

    Erase arrSortOrder

End Sub

Sub SplitDeSpiltOrderNum(arrSortOrder As Variant, rngSortValues As Range, blnConcatenate As Boolean)

    Dim arrSortValues

    Dim intRSortOrder   As Integer

    Dim intRSortValues  As Integer

    arrSortValues = rngSortValues

    For intRSortOrder = LBound(arrSortOrder, 1) To UBound(arrSortOrder, 1)

        For intRSortValues = LBound(arrSortValues, 1) To UBound(arrSortValues, 1)

            If blnConcatenate = True Then

                If arrSortValues(intRSortValues, 1) = arrSortOrder(intRSortOrder, 2) Then

                    arrSortValues(intRSortValues, 1) = arrSortOrder(intRSortOrder, 1) & arrSortValues(intRSortValues, 1)

                End If

            Else

                If arrSortValues(intRSortValues, 1) = arrSortOrder(intRSortOrder, 1) & arrSortOrder(intRSortOrder, 2) Then

                    arrSortValues(intRSortValues, 1) = arrSortOrder(intRSortOrder, 2)

                End If

            End If

        Next intRSortValues

    Next intRSortOrder

    rngSortValues = arrSortValues

    Erase arrSortValues

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

Function rngCurRegionFromTopLeft(rngTopLeft As Range) As Range

    'Get Current region from specified top left position

    Set rngCurRegionFromTopLeft = Intersect(Range(rngTopLeft, rngTopLeft.SpecialCells(xlLastCell)), rngTopLeft.CurrentRegion)

End Function