Custom Sort On Column

[Paul_Hossler]

Try this with a hopefully non-existent custom sort entry

Option Explicit


Sub SortData()
    Dim rData As Range, rData1 As Range, rData2 As Range
    Dim r As Long, i As Long, iLastSort As String
    Dim arySorts As Variant
    Dim sLastSort As String


    arySorts = Array("Fire", "Natural event", "Flood", "Zombie Apocalypse")      '   starts at 0


    Set rData = ActiveSheet.Cells(1, 1).CurrentRegion
    Set rData1 = rData.Cells(2, 1).Resize(rData.Rows.Count - 1, rData.Columns.Count)


    Application.AddCustomList ListArray:=arySorts


    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rData1.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=Application.CustomListCount
        .SortFields.Add Key:=rData1.Columns(3), SortOn:=xlSortOnValues, Order:=xlDescending
        .SetRange rData
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
        .SortFields.Clear
    End With
    
    Set rData2 = Nothing
    With rData
        
        'see which last sort is in data
        For i = UBound(arySorts) To LBound(arySorts) Step -1
            iLastSort = -1
            On Error Resume Next
            iLastSort = Application.WorksheetFunction.Match(arySorts(i), Application.WorksheetFunction.Index(rData, 0, 2), 0)
            On Error GoTo 0
            
            'found custom sort value
            If iLastSort > -1 Then
                sLastSort = LCase(arySorts(i))
                Exit For
            End If
        Next i
    End With
        
            
    'custom sort value found
    If Len(sLastSort) > 0 Then
        
        With rData
            For r = .Rows.Count To 3 Step -1
                If LCase(.Cells(r, 2).Value) = sLastSort Then
                    Set rData2 = .Cells(r + 1, 1)
                    Set rData2 = Range(rData2, rData2.End(xlDown).End(xlToRight))
                    Exit For
                End If
            Next
        End With
    
        'MsgBox rData2.Address
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add Key:=rData2.Columns(3), SortOn:=xlSortOnValues, Order:=xlDescending
            .SetRange rData2
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
            .SortFields.Clear
        End With
    
    End If
    
    Application.DeleteCustomList ListNum:=Application.CustomListCount
    
End Sub