Custom Sort On Column

I'm trying to custom sort a column on a single worksheet.

The first part of my macro sorts by column 'B' (text column) alphabetically, then by column 'C' (date) newest first. This works fine.

The second part that I'm struggling to get working is custom sorting column 'B' once more based on certain keywords which are in an array.

Code:

---

Option Explicit

' Sort column B alphabetically, then by column C by date with most recent first

Sub SortData()
Columns.Sort key1:=Columns("B"), Order1:=xlAscending, Key2:=Columns("C"), Order2:=xlDescending

' Custom list sort order using keywords

ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add _
        Key:=Range("B1", Range("B1").End(xlDown)), SortOn:=xlSortOnValues, Order:=xlAscending, _
        CustomOrder:="Fire,Natural event,Flood", _
        DataOption:=xlSortNormal

End Sub

---

I'm new to using VBA and have searched high and low for what I'm sure is probably a very simple process.

Can the sort on column 'B' just include a single word from a cell, or does it have to contain all the words in a cell (including case sensitive)?

Thanks!

This sorts by event custom order and within each event newest to oldest.

If that's not what you want, then it can be adjusted

Custom sort cells can be upper or lower, but I think you're stuck with sorting the entire cell

Code:

---

Option Explicit


Sub SortData()
    Dim rData As Range, rData1 As Range


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


    Application.AddCustomList ListArray:=Array("Fire", "Natural event", "Flood")


    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=rData1.Columns(3), SortOn:=xlSortOnValues, Order:=xlDescending
        .SortFields.Add Key:=rData1.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=Application.CustomListCount
        .SetRange rData
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    Application.DeleteCustomList ListNum:=Application.CustomListCount
   
End Sub

---

Great stuff Paul, thank you!

I had to flip these lines about, as the key column is 'B' (sorry, my fault as I should've specified this in my original post).

Code:

---

.SortFields.Add Key:=rData1.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=Application.CustomListCount
        .SortFields.Add Key:=rData1.Columns(3), SortOn:=xlSortOnValues, Order:=xlDescending

---

Just one question if I may.

In the custom sort column, do I have to list all possible items that would show in it inside the array? Becasue I had to flip the two lines mentioned, the remainder of the list sorts itself alphabetically. Ideally I'd like for anything that isn't custom sorted to be "reorganized" by date again (column 'C'). Not sure if this is possible?

Thanks!

Quote:

---

In the custom sort column, do I have to list all possible items that would show in it inside the array? Becasue I had to flip the two lines mentioned, the remainder of the list sorts itself alphabetically. Ideally I'd like for anything that isn't custom sorted to be "reorganized" by date again (column 'C'). Not sure if this is possible?

---

This isn't the most generalized, but seems to work. I.e., fails if no "flood" or "flood" isn't last in custom list

If a real problem, I'll look at those two situations, but it'll complicate the macro somewhat

Code:

---

Option Explicit


Sub SortData()
    Dim rData As Range, rData1 As Range, rData2 As Range
    Dim r As Long


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


    Application.AddCustomList ListArray:=Array("Fire", "Natural event", "Flood")


    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
   
    Application.DeleteCustomList ListNum:=Application.CustomListCount
   
    Set rData2 = Nothing
    With rData
        For r = .Rows.Count To 3 Step -1
            If LCase(.Cells(r, 2).Value) = "flood" Then
                If Len(.Cells(r, 2).Value) > 0 Then
                    Set rData2 = .Cells(r + 1, 1)
                    Set rData2 = Range(rData2, rData2.End(xlDown).End(xlToRight))
                    Exit For
                End If
            End If
        Next
    End With
   
    'MsgBox rData2.Address
   
    If Not rData2 Is Nothing Then
        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
   
End Sub

---

Thanks for taking another look, Paul.

This does indeed work, although you have pointed out that it will fail if no "flood" or "flood" isn't last in custom list. I'm at a dilemma as this is likely to be an issue, but am conscious of the amount of time you have spent trying to help me with my query.

Just another thought, what will happen if one or more of the items in the custom array are not found? [EDIT - Nothing happens! Phew!!]

Thanks!

Try this with a hopefully non-existent custom sort entry

Code:

---

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

---

Paul, what can I say?

Brilliant! Thank you!!

I really do take my hat off to you for helping me. :bow:

I'm now going to try and fathom out what all the code is doing piece by piece.

<blush>

No problem

I tied to include comments to explain any flow that was not obvious, and the online help explains the VBA pretty well

Come back if you have a question