Consulting

Results 1 to 8 of 8

Thread: Custom Sort On Column

  1. #1
    VBAX Mentor
    Joined
    Aug 2020
    Location
    Hampshire
    Posts
    395
    Location

    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.

    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!

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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

    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
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3
    VBAX Mentor
    Joined
    Aug 2020
    Location
    Hampshire
    Posts
    395
    Location
    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).

    .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!

  4. #4
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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


    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
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  5. #5
    VBAX Mentor
    Joined
    Aug 2020
    Location
    Hampshire
    Posts
    395
    Location
    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!
    Last edited by HTSCF Fareha; 10-21-2020 at 11:52 AM.

  6. #6
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  7. #7
    VBAX Mentor
    Joined
    Aug 2020
    Location
    Hampshire
    Posts
    395
    Location
    Paul, what can I say?

    Brilliant! Thank you!!

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

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

  8. #8
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    <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
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •