A difficult sort

Try the attached.

This code is capable to handle the records that doesn't match to the list.
(list those to the last)

Option Explicit

Sub test()
    mySort
    AddSheet
End Sub

Private Sub mySort()
    Dim a, i As Long, ii As Long, SL As Object
    Dim myNum As String, Grade, w
    Set SL = CreateObject("System.Collections.SortedList")
    ReDim w(1 To 2)
    With Sheets("Lists").Range("a1").CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            If a(i, 3) <> "" Then
                a(i, 3) = CStr(a(i, 3))
                If Not SL.contains(i) Then
                    w(1) = a(i, 3)
                    Set w(2) = CreateObject("System.Collections.ArrayList")
                    SL(i) = w
                End If
                w = SL(i)
                For ii = 2 To UBound(a, 1)
                    If a(ii, 2) <> "" Then
                        a(ii, 2) = Replace(a(ii, 2), "-", "")
                        w(2).Add a(ii, 2)
                        SL(i) = w
                    Else
                        Exit For
                    End If
                Next
            Else
                Exit For
            End If
        Next
        ReDim Preserve a(1 To UBound(a, 1), 1 To 1)
        ReDim Preserve a(1 To UBound(a, 1), 1 To 2)
        For i = 2 To UBound(a, 1)
            myNum = "zzz": Grade = "zzz"
            If a(i, 1) Like "*X*" Then
                myNum = Val(Mid$(a(i, 1), InStr(1, a(i, 1), "X", 1) + 1))
            End If
            If a(i, 1) Like "* *" Then
                Grade = Replace(Split(a(i, 1) & "-")(1), "-", "")
            End If
            For ii = 0 To SL.Count - 1
                If SL.GetByIndex(ii)(1) = myNum Then
                    a(i, 2) = Format$(ii, "00000") & _
                    Format$(SL.GetByIndex(ii)(2).IndexOf(Grade, 0), "00000")
                    Exit For
                End If
            Next
            If a(i, 2) = "" Then a(i, 2) = "zzz" & a(i, 1)
        Next
        SL.Clear
        For i = 2 To UBound(a, 1)
            SL(a(i, 2)) = a(i, 1)
        Next
        For i = 0 To SL.Count - 1
            a(i + 2, 1) = SL.GetByIndex(i)
        Next
        .Resize(, 1).Value = a
    End With
End Sub

Private Sub AddSheet()
    Dim i As Long
    With Sheets("Lists")
        For i = .Range("a" & Rows.Count).End(xlUp).Row To 2 Step -1
            If Not IsSheetExists(.Cells(i, 1).Value) Then
                Sheets.Add(after:=Sheets("Lists")).Name = .Cells(i, 1).Value
            End If
            With Sheets(.Cells(i, 1).Value)
                .Move after:=Sheets("Lists")
                .Cells(1).Value = .Name
            End With
        Next
    End With
End Sub

Function IsSheetExists(ByVal txt As String) As Boolean
    On Error Resume Next
    IsSheetExists = Len(Sheets(txt).Name)
    On Error GoTo 0
End Function