Custom Sorting Range Based on Another Column

https://stackoverflow.com/questions/65962480/sort-data-to-match-order-of-a-list-column-excel-vba/65963701#65963701

Well... Custom Sort Lists are almost easier to use in the GUI vs VBA. There are a few things I want to note before I move on.

There is a twist between .Cells.Sort.SortFields.Add and .Cells.Sort that usually generates some confusion. The .SortFields.Add method uses a CustomOrder:= parameter and the Range.Sort method uses a OrderCustom:= parameter. The two are most definitely NOT the same but often get used interchangeably with disastrous results.

https://stackoverflow.com/a/32682618/5079799

I found that I could not get OrderCustom to work as it always sorted either via xlAscending/Descending which the whole point of this exercise is I want to sort my output in a non alphanumerical way. (But this would be my preferred way, and reference the Custom List via it's "integer value")

I also spent a lot of time reading this article, which teaches about creating/saving/finding/delete Custom Order lists. But, I couldn't actually find a way to use a list I "created".

https://exceloffthegrid.com/vba-for-customlists-autofill-lists/

In the end I just used a simple "For Loop" to generate a String from each cells value in the "Custom Column" in the format of "One,Two,Three" and fed that to CustomOrder:=CVar(CustomOrderStr) make sure to use CVar!

Here is the code, note lots of this isn't needed, but I left it all for posterity:

Functions:

Public Function CustomOrderStrFromRng(rng As Range) As String
'Generate String for "CustomOrder:="Str1,Str2"
 For Each rcell In rng.Cells
  CustomOrderStrFromRng = CustomOrderStrFromRng & rcell.Value & ","
 Next rcell
 CustomOrderStrFromRng = Left(CustomOrderStrFromRng, Len(CustomOrderStrFromRng) - 1)
End Function

Public Function CustomListFromRange(rng As Range) As Integer
'Either Create or Return Int Value for Custom List
 Dim CustomListArr As Variant
 CustomListArr = RangeToArray(rng)
 On Error Resume Next
  Application.AddCustomList ListArray:=Array(CustomListArr)
 On Error GoTo 0
 CustomListFromRange = Application.GetCustomListNum(Array(CustomListArr))
 Debug.Print "Custom List Int = " & CustomListFromRange
End Function

Public Function NumberOfCustomLists() As Integer
 NumberOfCustomLists = Application.CustomListCount
 Debug.Print "NumberOfCustomLists = " & NumberOfCustomLists
End Function

Public Sub DelCustomList(ListInt As Integer)
 Application.DeleteCustomList listNum:=ListInt
End Sub

Public Function lRowOfCol(Optional ByVal ColNum As Long, Optional ByVal ColLet As String, Optional ByVal Endxl As String) As Long
    If StrComp(Endxl, "DOWN", vbTextCompare) = 0 Then
     If ColNum > 0 Then
      lRowOfCol = Cells(1, ColNum).End(xlDown).Row
     Else
      lRowOfCol = Range(ColLet & "1").End(xlDown).Row
     End If
    Else
     If ColNum > 0 Then
      lRowOfCol = Cells(Rows.Count, ColNum).End(xlUp).Row
     Else
      lRowOfCol = Range(ColLet & Rows.Count).End(xlUp).Row
     End If
    End If
End Function

Public Function RangeToArray(rng As Range) As Variant
    Dim i As Long, r As Range
    ReDim arr(1 To rng.Count)

    i = 1
    For Each r In rng
        arr(i) = r.Value
        i = i + 1
     Next r

    RangeToArray = arr
End Function

Subs:

Public Sub CustomSortDataFromColumn(DataRng As Range, CustomListColStr As String, KeyColStr As String)

Dim CustomListCol As Range, CustomListCollRow As Integer, CustomListColInt As Integer
Dim KeyCol As Range, KeyCollRow As Integer, KeyColInt As Integer

CustomListColInt = Columns(CustomListColStr).Column
CustomListCollRow = lRowOfCol(CustomListColInt)
Set CustomListCol = Range(Cells(2, CustomListColInt), Cells(CustomListCollRow, CustomListColInt))

KeyColInt = Columns(KeyColStr).Column
KeyCollRow = lRowOfCol(KeyColInt)
Set KeyCol = Range(Cells(2, KeyColInt), Cells(KeyCollRow, KeyColInt))

Dim CustomOrderStr As String
CustomOrderStr = CustomOrderStrFromRng(CustomListCol)

ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=KeyCol, SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=CVar(CustomOrderStr)
With ActiveSheet.Sort
    .SetRange DataRng
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

End Sub

Public Sub Test_CustomSortDataFromColumn()
 
 Dim DataRng As Range, CustomListCol As String, KeyCol As String
 Set DataRng = Range("A1:G70")
 CustomListCol = "I"
 KeyCol = "E"

 Call CustomSortDataFromColumn(DataRng, CustomListCol, KeyCol)

End Sub

Public Sub TestingCustomLists()

 Dim NoOfLists As Integer
 NoOfLists = NumberOfCustomLists()

 Dim CusListRng As Range, CusListInt As Integer
 Set CusListRng = Range("I2:I70")

 CusListInt = CustomListFromRange(CusListRng)
 Debug.Print "CusListInt = " & CusListInt

 NoOfLists = NumberOfCustomLists()

 Call DelCustomList(CusListInt)

 NoOfLists = NumberOfCustomLists()

End Sub

Public Sub SortRangeByCustomList()

 Dim DataRng As Range, CustomListCol As Range, KeyCol As Range
 Set DataRng = Range("A1:G70")
 Set CustomListCol = Range("I2:I70")
 Set KeyCol = Range("E2:E70")

 Dim CustomOrderStr As String
 CustomOrderStr = CustomOrderStrFromRng(CustomListCol)

 ActiveSheet.Sort.SortFields.Clear
 ActiveSheet.Sort.SortFields.Add Key:=KeyCol, SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=CVar(CustomOrderStr)
 With ActiveSheet.Sort
     .SetRange DataRng
     .Header = xlYes
     .MatchCase = False
     .Orientation = xlTopToBottom
     .SortMethod = xlPinYin
     .Apply
 End With

End Sub

Page tree

Custom Sorting Range Based on Another Column