Custom sort without custom list

Hello everybody
I have a sheet named "Data" which contains cutom list on which I need to sort column C in sheets("Report")
I don't want to use custom list feature ( Application.AddCustomList )


I need to depend on the custom list in range("B2:B8") in sheets("Data")

I found UDF function but can't apply it
This my try but I got an error

Sub CustomSort()
    Dim Sh As Worksheet, LR As Long
    Set Sh = Sheets("Report")
    LR = Sh.Cells(Rows.Count, 1).End(xlUp).Row
    Sh.Range("A4:E" & LR).Sort Key1:=Range("C4"), OrderCustom:=SortItems, Header:=xlYes
End Sub

Function SortItems() As String
    Dim ArrSort() As Variant
    Dim RngSort As Range
    Dim I As Long
    
    With Worksheets("Data")
        Set RngSort = .Range("B1:B" & .Cells(Rows.Count, "B").End(xlUp).Row)
    End With
    
    ReDim ArrSort(1 To RngSort.Rows.Count)
    For I = 2 To UBound(ArrSort)
        ArrSort(I) = RngSort(I, 1)
    Next

    SortItems = Join(ArrSort, ",")
End Function

The error is at this line

Sh.Range("A4:E" & LR).Sort Key1:=Range("C4"), OrderCustom:=SortItems, Header:=xlYes

Sort method of range failed 1004

You must use Sort object not Sort method:

Sub CustomSort()
    Dim Sh As Worksheet, LR As Long
    Set Sh = Sheets("Report")
    LR = Sh.Cells(Rows.Count, 1).End(xlUp).Row
    With Sh.Sort
        .SortFields.Clear
        .SortFields.Add Sh.Range("C4"), CustomOrder:=SortItems
        .SetRange Sh.Range("A4:E" & LR)
        .Header = xlYes
        .Apply
    End With
End Sub

Sortitems function returns string with leading comma but this does not seem to matter.

Mr. Izandol
Thank you very very much for this correction
It works great

Another point in this thread I need to ask about .. what if I have a nother cutom list in another range and I need to apply it too
How can I do that?
See the attachment for second custom list

You may add another sort field in same way

Last point I need add column E but sort it in normal way in ascending order
It is now OK with column C and D but not ok in column E

Thanks for reply

I tried that and everything is ok

Sub CustomSort()
    Dim Sh As Worksheet, LR As Long
    Set Sh = Sheets("Report")
    LR = Sh.Cells(Rows.Count, 1).End(xlUp).Row
    With Sh.Sort
        .SortFields.Clear
        .SortFields.Add Sh.Range("C4"), CustomOrder:=SortItemsA
        .SetRange Sh.Range("A4:E" & LR)
        .Header = xlYes
        .Apply
    End With
    
    With Sh.Sort
        .SortFields.Clear
        .SortFields.Add Sh.Range("D4"), CustomOrder:=SortItemsB
        .SetRange Sh.Range("A4:E" & LR)
        .Header = xlYes
        .Apply
    End With
End Sub

Function SortItemsA() As String
    Dim ArrSort() As Variant
    Dim RngSort As Range
    Dim I As Long
    
    With Worksheets("Data")
        Set RngSort = .Range("B1:B" & .Cells(Rows.Count, "B").End(xlUp).Row)
    End With
    
    ReDim ArrSort(1 To RngSort.Rows.Count)
    For I = 2 To UBound(ArrSort)
        ArrSort(I) = RngSort(I, 1)
    Next

    SortItemsA = Join(ArrSort, ",")
End Function

Function SortItemsB() As String
    Dim ArrSort() As Variant
    Dim RngSort As Range
    Dim I As Long
    
    With Worksheets("Data")
        Set RngSort = .Range("C1:C" & .Cells(Rows.Count, "C").End(xlUp).Row)
    End With
    
    ReDim ArrSort(1 To RngSort.Rows.Count)
    For I = 2 To UBound(ArrSort)
        ArrSort(I) = RngSort(I, 1)
    Next

    SortItemsB = Join(ArrSort, ",")
End Function

But is there an efficient way to make the function more flexible as I intend to add more than two custom lists ..?

That is not problem - you must only create new sort list and use with CustomOrder on new sortfield.

Originally Posted by Izandol

That is not problem - you must only create new sort list and use with CustomOrder on new sortfield.

I know but I am searching for a way to merge all in one function
instead of creating one by one

Function SortItemsA() As String

Function SortItemsB() As String

Function SortItemsC() As String

to be only in one

Function SortItems() As String

so as to have just one function for all custom lists

Thanks a lot I solved last point by putting this line

.SortFields.Add Key:=Rng.Columns(5), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers

After these two lines

        .SortFields.Add Key:=Rng.Columns(3), CustomOrder:=SortItems(2)
        .SortFields.Add Key:=Rng.Columns(4), CustomOrder:=SortItems(3)

Mr. Nilem
I really apprciate this great and wonderful help
It is very very well after I removed this line and the results are ok for column C & D

.SortFields.Add Key:=Rng.Columns(5), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers

After adding this line again
I got incorrect results ..
My problem now is with column E only ..but as for custom sort it is ok

I would suggest more general function:

Sub CustomSort()
    Dim Sh As Worksheet, LR As Long
    Dim ws as Worksheet
    Set Sh = Sheets("Report")
    Set ws = worksheets("Data")
    LR = Sh.Cells(Rows.Count, 1).End(xlUp).Row
    With Sh.Sort
        .SortFields.Clear
        .SortFields.Add Sh.Range("C4"), CustomOrder:=SortItems(ws.Range("B2", ws.Cells(Rows.Count, "B").End(xlUp)))
        .SortFields.Add Sh.Range("D4"), CustomOrder:=SortItems(ws.Range("C2", ws.Cells(Rows.Count, "C").End(xlUp)))
        .SortFields.Add Key:=Sh.Range("E4"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        .SetRange Sh.Range("A4:E" & LR)
        .Header = xlYes
        .Apply
    End With
End Sub

Function SortItems(rngSort As Range) As String
    Dim ArrSort() As Variant
    Dim I As Long
    
    ReDim ArrSort(1 To rngSort.Rows.Count)
    For I = 1 To UBound(ArrSort)
        ArrSort(I) = rngSort(I, 1)
    Next

    SortItems = Join(ArrSort, ",")
End Function

Posted two times

Thank you very much Mr. Izandol
I got an error at this line

.SortFields.Add Sh.Range("C4"), CustomOrder:=SortItems(.Range("B2", .Cells(Rows.Count, "B").End(xlUp)))

'Error 438 : Object doesn't support this property or method

Yes - I fix this just now. Please use changed code.

Great & Excellent & Awesome. Thank you very much Mr. Izandol
I'm very pleased with your sharing in this thread
Mr. Nilem
Thanks a lot for great and wonderful help you offered
Kind Regards