Custom sort with large number of items

I have data in a dynamic range which I want to sort horizontally by the values in the 1st row. A macro fills a range, e.g. ("a2 to f12") with names in row 2 and data below, and then it pastes names from another sheet in row 1. The names in row 1 also appear in row 2 but in a different order.

Then I want to sort the data in the range by the names in row 1 as below:

The code I use is:

Dim sht As Worksheet
Set sht = ActiveSheet   'Sheet name: Data
Dim bottom As Long, right As Long
With sht
    bottom = .Cells(2, 2).End(xlDown).Row
    right = .Cells(2, 2).End(xlToRight).Column
End With

Application.AddCustomList ListArray:=Sheets("Data").Range(Cells(1, 1), Cells(1, right)), ByRow:=False

ActiveWorkbook.Worksheets("Data").Range(Cells(2, 1), Cells(bottom, right)).Sort Key1:=Range(Cells(2, 1), _ Cells(2, right)), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=Application.CustomListCount + 1, _ MatchCase:=False, Orientation:=xlLeftToRight, DataOption1:=xlSortNormal

Application.DeleteCustomList Application.CustomListCount

While the code usually works, sometimes it doesn't because the number of items can be several hundreds and it exceeds the limit of the custom list so, part of the data remains unsorted. Also, after I delete the custom list, Excel crashes. Is there any other way to sort my data without using a custom list?

Custom-Sort Rows

• Qualify your worksheets and ranges: if you know the worksheet name, you don't want to use ActiveSheet; these cells Cells(bottom, right) are located in a worksheet, so qualify them.
• Right is a VBA function. Surely you can make up your own variable name, e.g. rCol, cRight...
• Once you have added a custom list, its count has increased by 1, so the index Application.CustomListCount + 1 shouldn't exist.
• Related to the ByRow argument, the documentation states: "If this argument is omitted and there are more columns than rows in the range, Excel creates a custom list from each row in the range." This is true in our case: there are 6 columns and 1 row so "each row" is our only row hence one custom list will be added.

Sub SortColumns()
    
    Dim iclCount As Long: iclCount = Application.CustomListCount ' initial
    
    On Error GoTo ClearError ' start error-handling routine
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Sheets("Data")
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
    
    Application.AddCustomList rg.Rows(1)
    
    With rg.Resize(rg.Rows.Count - 1).Offset(1) ' exclude first row
        .Sort .Rows(1), xlAscending, , , , , , xlNo, iclCount + 1, , xlSortRows
    End With
    
ProcExit: ' Exit Routine
    On Error Resume Next ' prevent endless loop if error in the following lines
        With Application
            ' Delete all newly added custom lists (it's only one in this case).
            Do While .CustomListCount > iclCount
                .DeleteCustomList .CustomListCount
            Loop
        End With
    On Error Resume Next
    Exit Sub
ClearError: ' continue error-handling routine
    Debug.Print "Run-time error '" & Err.Number & "':" & vbLf & Err.Description
    Resume ProcExit ' redirect to exit routine
End Sub