Sort By Color

Vishesh's picture

Excel doesn't provide anything to sort on color. Here is a customised code snippet to achieve the same. Download the attached Excel file to to see how to implement color sorting in Excel range.

Custom Sort


 

 

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
 
 
 
AttachmentSize
ColorSort.xlsm23.25 KB