Problem in a custom sort code

[Benten667]

Hello the forum,

I have a problem in the code of my workbook, code that I attach in the topic with the file. I would like to do a custom sorting in all the tabs in column E by means of a vba code. Because this file will be shared and it is not possible to export a personal sort...

Thank you in advance for your help.

Private Sub CommandButton1_Click()
    Dim Ws As Worksheet
    On Error Resume Next
    For Each Ws In Worksheets
        If Ws.Name <> "CONFIG" Then
            With Ws.ListObjects(1)
    Sort.SortFields.Clear
    Sort.SortFields.Add _
        Key:=Range("E:E"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, CustomOrder:=" 1-0-0,1-1-0,1-1-1,1-1-2,1-1-3,1-1-4,1-2-0,1-2-1,1-2-2,1-2-3,1-2-4,1-3-0,1-3-1,1-3-2,1-3-3,1-3-4,1-4-0,1-4-1,1-4-2,1-4-3,1-4-4,1-5-0,1-5-1,1-5-2,1-5-3,1-5-4,1-6-0,1-6-1,1-6-2,1-6-3,1-6-4,1-7-0,1-7-1,1-7-2,1-7-3,1-7-4,1-8-0,2-0-0,3-0-0,2-1-0,2-1-1,2-1-2,2-1-3,3-1-1,3-1-2,3-1-3,3-1-4,2-2-0,2-2-1,2-2-2,2-2-3,3-2-1,3-2-2,3-2-3,3-2-4,2-3-0,2-3-1,2-3-2,2-3-3,3-3-1,3-3-2,3-3-3,3-3-4,2-4-0,2-4-1,2-4-2,2-4-3,3-4-1,3-4-2,3-4-3,3-4-4,2-5-0,2-5-1,2-5-2,2-5-3,3-5-1,3-5-2,3-5-3,3-5-4,3-6-1,3-6-2,3-6-3,3-6-4,2-6-0,2-6-1,2-6-2,2-6-3,3-7-1,3-7-2,3-7-3,3-7-4,3-8-1,3-8-2,3-8-3,3-8-4,2-7-0,2-7-1,2-7-2,2-7-3,2-8-0,5-1-0,5-2-0,5-3-0,4-1-0,4-2-0,4-3-0,4-4-0,5-4-0,5-5-0,4-5-0,4-6-0,5-6-0,5-6-1,5-7-0,4-7-0,4-8-0,5-8-0,5-8-1,5-9-0,4-9-0,4-10-0,5-10-0,5-11-0,6-1-0,6-2-0,6-3-0,6-4-0,6-5-0,6-6-0,6-7-0,6-8-0,6-9-0,6-10-0,6-11-0,0,Sur chaîne,A determiner,Servantes visserie", DataOption:=xal
    With Ws.ListObjects(1).Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    End With
    End If
    Next
End Sub

[nilem]

Hi Benten667,
try this

Sub SortColumnsE()
Dim Ws As Worksheet, Rng As Range

For Each Ws In ThisWorkbook.Sheets
    If Ws.Name <> "CONFIG" Then
        Set Rng = Ws.Range("D3").CurrentRegion
        With Ws.Sort
            .SortFields.Clear
            .SortFields.Add Key:=Rng.Columns(2), SortOn:=xlSortOnValues, Order:= _
                            xlAscending, CustomOrder:="1-0-0,1-1-0,1-1-1,1-1-2,1-1-3,1-1-4,1-2-0,1-2-1," & _
                                                       "1-2-2,1-2-3,1-2-4,1-3-0,1-3-1,1-3-2,1-3-3,1-3-4,1-4-0,1-4-1,1-4-2,1-4-3,1-4-4," & _
                                                       "1-5-0,1-5-1,1-5-2,1-5-3,1-5-4,1-6-0,1-6-1,1-6-2,1-6-3,1-6-4,1-7-0,1-7-1,1-7-2," & _
                                                       "1-7-3,1-7-4,1-8-0,2-0-0,3-0-0,2-1-0,2-1-1,2-1-2,2-1-3,3-1-1,3-1-2,3-1-3,3-1-4," & _
                                                       "2-2-0,2-2-1,2-2-2,2-2-3,3-2-1,3-2-2,3-2-3,3-2-4,2-3-0,2-3-1,2-3-2,2-3-3,3-3-1," & _
                                                       "3-3-2,3-3-3,3-3-4,2-4-0,2-4-1,2-4-2,2-4-3,3-4-1,3-4-2,3-4-3,3-4-4,2-5-0,2-5-1," & _
                                                       "2-5-2,2-5-3,3-5-1,3-5-2,3-5-3,3-5-4,3-6-1,3-6-2,3-6-3,3-6-4,2-6-0,2-6-1,2-6-2," & _
                                                       "2-6-3,3-7-1,3-7-2,3-7-3,3-7-4,3-8-1,3-8-2,3-8-3,3-8-4,2-7-0,2-7-1,2-7-2,2-7-3," & _
                                                       "2-8-0,5-1-0,5-2-0,5-3-0,4-1-0,4-2-0,4-3-0,4-4-0,5-4-0,5-5-0,4-5-0,4-6-0,5-6-0," & _
                                                       "5-6-1,5-7-0,4-7-0,4-8-0,5-8-0,5-8-1,5-9-0,4-9-0,4-10-0,5-10-0,5-11-0,6-1-0,6-2-0," & _
                                                       "6-3-0,6-4-0,6-5-0,6-6-0,6-7-0,6-8-0,6-9-0,6-10-0,6-11-0,0,Sur chaîne,A determiner,Servantes visserie"
            .SetRange Rng
            .Header = xlYes
            .MatchCase = False
            .Apply
        End With
    End If
Next Ws
MsgBox "Ok", 64
End Sub

[Artik]

Benten667
The main problem with your code is that you are referencing a ListObject that is not there. Neither sheet contains a table (ListObject).
Like nilem, but I add a custom list temporarily.

Private Sub CommandButton1_Click()
    Dim Ws          As Worksheet
    Dim Rng         As Range
    Dim lLstCnt     As Long


    Application.AddCustomList listArray:=Split("1-0-0,1-1-0,1-1-1,1-1-2,1-1-3,1-1-4,1-2-0,1-2-1,1-2-2,1-2-3,1-2-4," & _
                                               "1-3-0,1-3-1,1-3-2,1-3-3,1-3-4,1-4-0,1-4-1,1-4-2,1-4-3,1-4-4," & _
                                               "1-5-0,1-5-1,1-5-2,1-5-3,1-5-4,1-6-0,1-6-1,1-6-2,1-6-3,1-6-4," & _
                                               "1-7-0,1-7-1,1-7-2,1-7-3,1-7-4,1-8-0,2-0-0,3-0-0," & _
                                               "2-1-0,2-1-1,2-1-2,2-1-3,3-1-1,3-1-2,3-1-3,3-1-4,2-2-0,2-2-1,2-2-2,2-2-3," & _
                                               "3-2-1,3-2-2,3-2-3,3-2-4,2-3-0,2-3-1,2-3-2,2-3-3,3-3-1,3-3-2,3-3-3,3-3-4," & _
                                               "2-4-0,2-4-1,2-4-2,2-4-3,3-4-1,3-4-2,3-4-3,3-4-4,2-5-0,2-5-1,2-5-2,2-5-3," & _
                                               "3-5-1,3-5-2,3-5-3,3-5-4,3-6-1,3-6-2,3-6-3,3-6-4,2-6-0,2-6-1,2-6-2,2-6-3," & _
                                               "3-7-1,3-7-2,3-7-3,3-7-4,3-8-1,3-8-2,3-8-3,3-8-4,2-7-0,2-7-1,2-7-2,2-7-3,2-8-0," & _
                                               "5-1-0,5-2-0,5-3-0,4-1-0,4-2-0,4-3-0,4-4-0,5-4-0,5-5-0,4-5-0,4-6-0," & _
                                               "5-6-0,5-6-1,5-7-0,4-7-0,4-8-0,5-8-0,5-8-1,5-9-0,4-9-0,4-10-0,5-10-0,5-11-0," & _
                                               "6-1-0,6-2-0,6-3-0,6-4-0,6-5-0,6-6-0,6-7-0,6-8-0,6-9-0,6-10-0,6-11-0,0," & _
                                               "Sur chaîne,A determiner,Servantes visserie", ",")

    lLstCnt = Application.CustomListCount

    'On Error Resume Next
    For Each Ws In Worksheets
        If UCase(Ws.Name) <> "CONFIG" Then
            With Ws
                Set Rng = .Range("D3").CurrentRegion
                With .Sort
                    .SortFields.Clear
                    .SortFields.Add Key:=Rng.Columns(2), _
                                    SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, _
                                    CustomOrder:=lLstCnt, _
                                    DataOption:=xlSortNormal
                    .SetRange Rng
                    .Header = xlYes
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
            End With
        End If
    Next Ws

    Application.DeleteCustomList ListNum:=lLstCnt
    ActiveCell.Activate

End Sub

Artik

[Benten667]

Hello, thank you both for your feedback which actually works in the excel case. I have simplified the basic file to make it easier to understand and access the code...

But unfortunately I forgot to format the tables hence the presence of the "ListObject" function in my original code.

Sorry I put the updated file in the topic above.

[nilem]

change

Set Rng = Ws.ListObjects(1).Range

instead of

Set Rng = Ws.Range("D3").CurrentRegion

[Benten667]

^^ Lazy when you hold us !
I should have been able to see this!

Anyway, thanks a lot Nilem! It's nice to have competent help