Sorting by one column, grouping by another

[Red over White]

Following a search of other threads, I tried the following program:

Dim Last As Long
Last = Range("A" & Rows.Count).End(xlUp).Row

Sheets("Current").Select
With Sheets("Current").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("E5:E" & Last), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("B5:B" & Last), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SetRange Range("A5:K" & Last)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

End Sub

To produce

Column B	Column E
Apples	60000
Apples	53000
Apples	22
Pears	55000
Oranges	54000
Oranges	16000

<colgroup><col span="2"></colgroup><tbody>
</tbody>

The idea being the highest number in column E appears at the top, followed by any subsequent number that shares the same product name in Column B

Any ideas how I produce this?

 

[RickXL]

Hi,

Oh dear, that means that two of the maximums in column E have the same valus.

This might be a workaround:

Sub mySort()
    Dim Last    As Long
    Dim ary     As Variant
    Dim i       As Long
    Dim dic     As Object
    Dim sl      As Object
    Dim Key     As Long
    Dim Item    As Long
    Dim dlm     As String
    Dim srt     As String
    
    With ThisWorkbook.Worksheets("Current")
        Last = .Range("B" & .Rows.Count).End(xlUp).Row
        ary = .Range("B5").Resize(Last - 4, 4)
        Set dic = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(ary)
            Key = ary(i, 1)
            Item = ary(i, 4)
            If dic(Key) < Item Then dic(Key) = Item
        Next

        Set sl = CreateObject("System.Collections.SortedList")
        For i = 0 To dic.Count - 1
            sl.Add dic.Items()(i) + i / dic.Count, dic.keys()(i)
        Next
        
        dlm = ""
        For i = sl.Count - 1 To 0 Step -1
            srt = srt & dlm & sl.GetByIndex(i)
            dlm = ","
        Next

        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("B5:B" & Last), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal, _
            CustomOrder:=CVar(srt)
            .SortFields.Add Key:=Range("E5:E" & Last), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            .SetRange Range("A5:K" & Last)
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub

It may not sort column B into the order you are expecting for that value with the duplicate. I don't know if you can live with that.

If not, what can you tell me about the values of the keys in column B and the values in column E? Will they always be integers? Could they ever be characters? Could they eved be floating point numbers (e.g. 12.34 etc)?


Regards,

 

[Red over White]

RickXL

This works, so thank you very much and means I can start 2017 with a useful tool. The coding is way out my league, and your efforts are much appreciated!

 

[RickXL]

Hi,

You might prefer this approach. It is more of an "Excel" way to do things and should work on Macs as well.

Instead of using obscure objects to find the maximum values and sort them behind the scenes, this uses a Pivot Table to do the same. It creates a temporary worksheet which it deletes after use. A Pivot Table is created from the data, the Pivot Table data is sorted into order then the Array for the Custom Sort Order is created as before.

Sub mySort2()
    Dim wsTmp       As Worksheet
    Dim wsCur       As Worksheet
    Dim pc          As PivotCache
    Dim pf          As PivotField
    Dim rngDat      As Range
    Dim rc          As Long
    Dim i           As Long
    Dim str         As String
    
    Application.ScreenUpdating = False
    Set wsTmp = ThisWorkbook.Worksheets.Add
    Set wsCur = ThisWorkbook.Worksheets("Current")

    With wsCur
        Set rngDat = .Range("A4:E4").Resize(.Cells(.Rows.Count, "B").End(xlUp).Row - 3)
    End With

    Set pc = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngDat)

    With wsTmp.PivotTables.Add(PivotCache:=pc, TableDestination:=wsTmp.Range("A1"))
        Set pf = .PivotFields(2)
        pf.Orientation = xlRowField
        
        With .PivotFields(5)
            .Orientation = xlDataField
            .Function = xlMax
        End With
        .PivotFields(2).AutoSort Order:=xlDescending, Field:=.DataFields(1)
    
        For i = 2 To .RowRange.Count - 1
            str = IIf(i = 2, CStr(.RowRange.Cells(i, 1)), str & "," & CStr(.RowRange.Cells(i, 1)))
        Next
    End With
    
    Application.DisplayAlerts = False
    wsTmp.Delete
    Application.DisplayAlerts = True

    With wsCur.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B4"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal, _
        CustomOrder:=CVar(str)
        .SortFields.Add Key:=Range("E4"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange rngDat
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Regards,