Microsoft 365 tri alphabétique particulier

    Application.ScreenUpdating = False
    [D:D].ClearContents
    ' Transfert données dans array
    DL = [B65500].End(xlUp).Row
    T = Range("B2:C" & DL)
    ' Séparation avec ". ", mise de la valeur en colonne 2
    For i = 1 To UBound(T)
        If T(i, 1) <> "" Then T(i, 2) = Split(T(i, 1), ". ")(1)
    Next i
    ' Tri alpha sur la colonne 2
    For i = 1 To UBound(T)
        For j = i To UBound(T)
            If T(i, 2) > T(j, 2) Then
                Buffer = T(i, 1): T(i, 1) = T(j, 1): T(j, 1) = Buffer
                Buffer = T(i, 2): T(i, 2) = T(j, 2): T(j, 2) = Buffer
            End If
        Next j
    Next i
    ' Chargement résultat dans la feuille
    [D2].Resize(UBound(T, 1), 1) = T
    ' Suppression des cases vides au début ( car les vides sont en premier en tri alpha )
    PL = [D1].End(xlDown).Row
    If PL > 2 Then Range("D2:D" & PL - 1).Delete Shift:=xlUp
End Sub

Sub TriAlphaSpecial2()
    Application.ScreenUpdating = False
    ' Insertion colonne en B
    Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    DL = [C65500].End(xlUp).Row
    ' Séparation avec ". ", mise de la valeur en colonne B
    For i = 1 To DL
        If Cells(i, "C") <> "" Then Cells(i, "B") = Split(Cells(i, "C"), ". ")(1)
    Next i
    ' Tri colonne B
    Range("B4:AG" & DL).Select
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("B4:B" & DL), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("B4:AG" & DL)
        .Header = xlGuess: .MatchCase = False: .SortMethod = xlPinYin: .Apply
    End With
    ' Suppression colonne B
    Columns("B:B").Delete Shift:=xlToLeft
    [A1].Select
End Sub