PDA

View Full Version : [SOLVED] Custom Sort On Column



HTSCF Fareha
10-20-2020, 01:35 PM
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!

Paul_Hossler
10-20-2020, 04:31 PM
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

HTSCF Fareha
10-21-2020, 03:36 AM
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!

Paul_Hossler
10-21-2020, 06:47 AM
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

HTSCF Fareha
10-21-2020, 09:20 AM
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!

Paul_Hossler
10-21-2020, 12:28 PM
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

HTSCF Fareha
10-21-2020, 02:33 PM
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.

Paul_Hossler
10-21-2020, 03:49 PM
<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