Sort column by VBA or formula

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
8,981
This was rather tricky. Try:
Code:
Private Sub Worksheet_Calculate()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim LastRow As Long, srcWS As Worksheet, Rng As Range, RngList As Object, key As Variant, fVisRow As Long, lVisRow As Long
    Set srcWS = Sheets("Sheet1")
    Columns("B:B").Insert Shift:=xlToRight
    Columns("A").ClearContents
    With srcWS
        .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Copy Cells(3, 1)
        .Range("K1", .Range("K" & .Rows.Count).End(xlUp)).Copy Cells(3, 2)
    End With
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Application.ScreenUpdating = True
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add key:=Range("B3:B" & LastRow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveSheet.Sort.SortFields.Add key:=Range("A3:A" & LastRow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("A3:B" & LastRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each Rng In Range("B3", Range("B" & Rows.Count).End(xlUp))
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next Rng
    With ActiveSheet.Outline
        .AutomaticStyles = False
        .SummaryRow = xlAbove
        .SummaryColumn = xlLeft
    End With
    Range("A2") = "a"
    Range("B2") = "b"
    For Each key In RngList
        With Cells(2, 1).CurrentRegion
            .AutoFilter 2, key
            fVisRow = Range("B3", Cells(Rows.Count, "B").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row + 1
            lVisRow = Cells(Rows.Count, "B").End(xlUp).Row
            Range("A" & fVisRow & ":B" & lVisRow).Rows.Group
        End With
        Range("A1").AutoFilter
    Next key
    Range("A2:B2").ClearContents
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add key:=Range("A3:A" & LastRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveSheet.Sort.SortFields.Add key:=Range("B3:B" & LastRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("A3:B" & LastRow)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    With ActiveSheet.Outline
        .AutomaticStyles = False
        .SummaryRow = xlBelow
        .SummaryColumn = xlRight
    End With
    ActiveSheet.UsedRange.Rows.Ungroup
    Columns("B").Delete
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 

Some videos you may like

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.

Russk68

Active Member
Joined
May 1, 2006
Messages
466
Hi Mumps
Does look quite complicated!
I will try this tonight and let you know how it worked out.
Thank you!
 

Russk68

Active Member
Joined
May 1, 2006
Messages
466
Hi Mumps
There are a few issues that I am having. I see that this is a large favor that I am asking so I understand if you do not wish to proceed.
Thank you for your time on this!
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
8,981
I can't promise a solution, but I don't mind having a look at your issues. I think it would be best to upload a copy of the actual file you are working with (de-sensitized if necessary) and explain the issues using a few examples from your data. A macro may work properly with a sample file but most often will not work with the actual file.
 

Watch MrExcel Video

Forum statistics

Threads
1,099,179
Messages
5,467,088
Members
406,523
Latest member
saravanantdct83

This Week's Hot Topics

Top