Advanced sorting in excel

I have a data in excel in the format:

Description      Name            Percent
Always             A               52
Sometimes          A               23
Usually            A               25      
Always             B               60
Sometimes          B               30
Usually            B               15 
Always             C               75
Sometimes          C               11
Usually            C               14

I want to sort this data:

For each name the sequence of description has to be same (eg: always followed by sometimes followed by usually) but for three names A, B and C, I want to sort the always percent from smallest to largest. Eg: I want the above example to look like this after sorting:

Description      Name开发者_开发知识库            Percent
Always             C               75
Sometimes          C               11
Usually            C               14      
Always             B               60
Sometimes          B               30
Usually            B               15 
Always             A               52
Sometimes          A               23
Usually            A               25

The always percent of name C was highest and always percent of name A was lowest. I hope I was able to explain it. I would really appreciate your help regarding the same.

Here's a vba routine to perform this sort:

Select the data on the sheet and run SortList

Important: this code assumes that the Always, Sometimes, Usually data is grouped by Name (as in your sample data)

Method:

Sub SortList()
    Dim dat As Variant
    Dim rng As Range
    Dim newDat() As Variant
    Dim always() As Long
    Dim i As Long

    Set rng = Selection

    If rng.Columns.Count <> 3 Then
        MsgBox "Select a range with 3 columns", vbCritical + vbOKOnly
        Exit Sub
    End If

    If StrComp(rng.Cells(1, 1), "Description", vbTextCompare) = 0 Then
        Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1, 3)
    End If

    dat = rng
    ReDim always(1 To UBound(dat, 1) / 3)

    For i = 1 To UBound(dat)
        If StrComp(dat(i, 1), "Always", vbTextCompare) = 0 Then
            always(i \ 3 + 1) = i
        End If
    Next

    QuickSort dat, always, LBound(always, 1), UBound(always, 1)


    ReDim newDat(1 To UBound(dat, 1), 1 To 3)
    For i = 1 To UBound(always)
        newDat((i - 1) * 3 + 1, 1) = dat(always(i), 1)
        newDat((i - 1) * 3 + 1, 2) = dat(always(i), 2)
        newDat((i - 1) * 3 + 1, 3) = dat(always(i), 3)

        ' Assumes original data is sorted in name order
        newDat((i - 1) * 3 + 2, 1) = dat(always(i) + 1, 1)
        newDat((i - 1) * 3 + 2, 2) = dat(always(i) + 1, 2)
        newDat((i - 1) * 3 + 2, 3) = dat(always(i) + 1, 3)
        newDat((i - 1) * 3 + 3, 1) = dat(always(i) + 2, 1)
        newDat((i - 1) * 3 + 3, 2) = dat(always(i) + 2, 2)
        newDat((i - 1) * 3 + 3, 3) = dat(always(i) + 2, 3)

    Next

    rng = newDat

End Sub


Private Sub QuickSort(ByRef dat As Variant, ByRef Field() As Long, ByVal LB As Long, ByVal UB As Long)
    Dim P1 As Long, P2 As Long, Ref As Variant, TEMP As Long

    P1 = LB
    P2 = UB
    Ref = dat(Field((P1 + P2) / 2), 3)

    Do
        Do While dat(Field(P1), 3) > Ref
            P1 = P1 + 1
        Loop

        Do While dat(Field(P2), 3) < Ref
            P2 = P2 - 1
        Loop

        If P1 <= P2 Then
            TEMP = Field(P1)
            Field(P1) = Field(P2)
            Field(P2) = TEMP

            P1 = P1 + 1
            P2 = P2 - 1
        End If
    Loop Until (P1 > P2)

    If LB < P2 Then Call QuickSort(dat, Field, LB, P2)
    If P1 < UB Then Call QuickSort(dat, Field, P1, UB)
End Sub

The Quicksort is adapted from this answer by Konrad Rudolph

It might be easier with ADO:

Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim i As Integer

strFile = "C:\Docs\Book2.xlsm"

''Note that if HDR=No, F1,F2 etc are used for column names,
''if HDR=Yes, the names in the first row of the range
''can be used.
''Comment out the connection string, as appropriate.
''This is the Jet 4 connection string, for < 2007:

strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
    & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"

''ACE, for 2007 -
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
    & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"

''Late binding, so no reference is needed

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")


cn.Open strCon

strSQL = "SELECT s1.[Description], s1.[Name], s1.[Percent] " _
       & "FROM [Sheet3$] s1 " _
       & "INNER JOIN (SELECT s.Name, s.Percent " _
       & "FROM [Sheet3$] s " _
       & "WHERE s.Description='Always') As s2 " _
       & "ON s1.Name = s2.Name " _
       & "ORDER BY s2.Percent DESC, s1.Description"

rs.Open strSQL, cn, 3, 3


''Pick a suitable empty worksheet or location for the results
With Worksheets("Sheet4")
    For i = 1 To rs.Fields.Count
        .Cells(1, i) = rs.Fields(i - 1).Name
    Next

    .Cells(2, 1).CopyFromRecordset rs
End With

''Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

Sort by Description. Add this formula to column D =RANK(VLOOKUP(INDIRECT("B"&ROW()),B:C, 2, FALSE),C:C ) and sort column D with Smallest to Largest.