Custom Sort Using a Comma Separated String Based on Range (Getting Overflow Error)

Question

This is an extension to my original question found here.

I want to use VBA (2016) to perform a custom sort, based on a pre-defined range. I know that the CustomOrder: takes a comma separated string, so I'm trying to feed it one of those, based on the values found in a column. I found a solution to transform a column into a comma separated string here, but when I try to implement it, I get an Overflow error (6).

To re-create, make a simple spreadsheet that looks like this (note the dates are already in ascending order):

Then use the below code to carry out the action. Basically, it first copies and pastes the values of the Serial Number column into its own column, removes those duplicates, then tries to use those unique values as the comma separated string to feed into the custom sort function for the original Serial Number column. Then just delete the unique values column:

Sub Macro7()

' Copy the serial numbers values into their own column
    Columns("A:A").Select
    Selection.Copy
    Range("D1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

' Remove the duplicates from that new column
    ActiveSheet.Range("$D$1:$D$7").RemoveDuplicates Columns:=1, Header:=xlYes
    Columns("A:A").Select

' Create a text string by transposing that column and adding commas to it
    Dim arr As String
    arr = Join(Application.Transpose(Range("D2", Range("D2").End(xlDown)).Value), ",")

' Try to sort the original Serial Number column based on the custom arr string made above
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("A2:A8") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        arr, DataOption:=xlSortNormal ' Here is where arr would normally read "2222,1111,3333,4444"
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:B8")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

' Delete the unique values column
    Columns("D:D").Select
    Selection.ClearContents
End Sub

I basically want the end result to look like this:

What am I missing? Thanks!

UPDATE

I guess I could add, that if you replace the line:

arr, DataOption:=xlSortNormal ' Here is where arr would normally read "2222,1111,3333,4444"

...with:

"2222,1111,3333,4444", DataOption:=xlSortNormal 

...the code works. So for some reason it's not reading the arr variable as a text string or some other reason like that? I don't want to manually define the CustomOrder every time, and would like this to be a step in my VBA, not done manually with the custom sort function. Thanks!

ANSWER UPDATE

The answer shown below works as well, but I found a really simple solution by changing the line:

arr, DataOption:=xlSortNormal ' Here is where arr would normally read "2222,1111,3333,4444"

...to:

CVar(arr), DataOption:=xlSortNormal ' Here is where arr would normally read "2222,1111,3333,4444"

...which I think is what converts the string to an "array of strings". Then it works. Thanks!

Answer 1

I couldn't get the Worksheet.Sort to work with a custom list, but I could using Range.Sort

Key elements are

• Custom list must be an array of Strings
• Add the list to the custom lists, sort, then remove it
• I also removed the reliance on Select/Active

Sub Demo()
    Dim ws As Worksheet
    Dim SortKeysRange As Range
    Dim SortDataRange As Range
    Dim UniqueKeysRange As Range
    Dim arr() As String, i As Long

    On Error GoTo EH

    Set ws = ActiveSheet ' Update as required
    With ws
        Set SortKeysRange = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))
        Set UniqueKeysRange = .Cells(1, 4)

        ' Copy the serial numbers values into their own column
        UniqueKeysRange.Cells(1, 1).Resize(SortKeysRange.Rows.Count, 1) = SortKeysRange.Value

        ' Remove the duplicates from that new column
        Set UniqueKeysRange = .Range(UniqueKeysRange, UniqueKeysRange.End(xlDown))
        UniqueKeysRange.RemoveDuplicates Columns:=1, Header:=xlYes

        Set SortDataRange = SortKeysRange.Resize(, 2)

        ' Create a text string by transposing that column and adding commas to it
        Set UniqueKeysRange = .Range(UniqueKeysRange.Cells(2, 1), UniqueKeysRange.Cells(2, 1).End(xlDown))
        ReDim arr(1 To UniqueKeysRange.Rows.Count)
        For i = 1 To UniqueKeysRange.Rows.Count
            arr(i) = CStr(UniqueKeysRange.Cells(i, 1))
        Next

        'Add custom list
        Application.AddCustomList arr ', True
        i = Application.GetCustomListNum(arr)

        ' Sort
        SortDataRange.Sort _
          Key1:=SortDataRange.Cells(1, 1), _
          Order1:=xlAscending, _
          OrderCustom:=i + 1, _
          Header:=xlYes, _
          MatchCase:=False, _
          Orientation:=xlTopToBottom, _
          SortMethod:=xlPinYin

    End With

EH:

    ' Delete Custom List
    Application.DeleteCustomList i

    ' Delete the unique values column
    UniqueKeysRange.EntireColumn.Clear
End Sub