Excel crashes while deleting custom list

Hi
I need to multilevel sort my data. Buttons on my userform from top left need to be clicked in the counting sequence . The six buttons are working fine if I save my wb after applying the functionality of above six buttons then no error but when I click the last button "EmailFlagCustomSort" and then save the wb ,Excel crashes.Problem is solved if I uncomment the red bold line of code.but I cannot execute that line because it will clear the the sorting of above 6 buttons while I want to preserve that sorting and then apply the last button custom sorting. Now the other workaround is that I should comment out the green line (which is actually deleting my custom list after performing the sorting. Reason I want to delete the custom list is that it does not allow me to copy the email flag down (it will replicate the custom list which I don't want).

Any help would be greatly appreciated . I am struggling the situation for the last 8 hours.SAMPLE WB IS ATTACHED

Public Sub EmailFlagCustomSort()
Application.DeleteCustomList Application.CustomListCount + 1
Dim DataValues As Worksheet
Dim RngDataValues As Range
Dim Contacts As Worksheet
Dim RngContacts
Dim LstRow As Long
Dim N As Integer
Dim arr As Variant
Application.EnableEvents = False
Set DataValues = ThisWorkbook.Sheets("DataValues")
LstRow = DataValues.Range("BO" & Rows.Count).End(xlUp).Row
Set RngDataValues = DataValues.Range("BO2:BO" & LstRow)
Set Contacts = ThisWorkbook.Sheets("Contacts")
Set RngContacts = Contacts.Range("J2:J" & Contacts.Range("J" & Rows.Count).End(xlUp).Row)
arr = Application.Transpose(RngDataValues)
'MsgBox UBound(arr)
'On Error Resume Next
'    ActiveSheet.Sort.SortFields.Clear
    Application.AddCustomList ListArray:=arr
    N = Application.GetCustomListNum(arr)
    Contacts.Range("A2:Z" & Contacts.Range("A" & Rows.Count).End(xlUp).Row).Sort Key1:=Range("J2"), Order1:=xlAscending, _
                            Header:=xlNo, Orientation:=xlSortColumns, _
                            OrderCustom:=N + 1
    Erase arr
'***********************
'ActiveSheet.Sort.SortFields.Clear
' Application.EnableEvents = True
Application.DeleteCustomList N
'**********************
End Sub

Best Regards
Imran Bhatti

You could simply avoid adding the custom list at all

Public Sub EmailFlagCustomSort()
Dim DataValues As Worksheet
Dim RngDataValues As Range
Dim Contacts As Worksheet
Dim RngContacts
Dim LstRow As Long
Dim N As Integer
Dim arr As Variant
Application.EnableEvents = False
Set DataValues = ThisWorkbook.Sheets("DataValues")
LstRow = DataValues.Range("BO" & Rows.Count).End(xlUp).Row
Set RngDataValues = DataValues.Range("BO2:BO" & LstRow)
Set Contacts = ThisWorkbook.Sheets("Contacts")
Set RngContacts = Contacts.Range("J2:J" & Contacts.Range("J" & Rows.Count).End(xlUp).Row)
arr = Application.Transpose(RngDataValues)
'MsgBox UBound(arr)
'On Error Resume Next
'    ActiveSheet.Sort.SortFields.Clear
    With Contacts.Sort
        With .SortFields
            .Clear
            .Add Key:=Contacts.Range("J2"), Order:=xlAscending, CustomOrder:=Join(arr, ",")
        End With
        .SetRange Contacts.Range("A2:Z" & Contacts.Range("A" & Rows.Count).End(xlUp).Row)
        .Header = xlNo
        .Orientation = xlSortColumns
        .Apply
    End With
    Erase arr
'***********************
'ActiveSheet.Sort.SortFields.Clear
' Application.EnableEvents = True
'**********************
End Sub

Hi xlnitwit thanks for the kind review

Just to be responsive I inform you that currently I am cross checking your solution against the other sorting buttons will take some while. I will let you know the results.

Hello again
Sorry for the delay. Its raining here and there was a temporary electricity failure. The solution worked like a charm. Thank so very much for your time to review the problem.Never thought of that sorting on the basis of a list without creating a custom list
Again a bundle of thanks xlnitwit.

Best Regards
Imran Bhatti

You're welcome, and thank you for the rep.