Option Explicit

Sub SortListObjectByCellValue()
    SortListObject ActiveSheet.ListObjects("Таблица1"), Range("Q1")
End Sub

Sub SortListObject(lo As ListObject, sortString As String)
    
    sortString = Replace(sortString, " ", "")
    Dim arr As Variant
    Dim brr As Variant
    arr = Split(sortString, ",")
    
    Dim wb As Workbook
    Set wb = Workbooks.Add(1)
    With wb.Sheets(1)
        .Cells(1, 2).Resize(1, UBound(arr) + 1) = arr
        arr = Application.Transpose(lo.Range)
        .Cells(2, 2).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        With .Cells(2, 1).Resize(UBound(arr, 1), 1)
            .FormulaR1C1 = "=IFERROR(MATCH(RC[1],R1,0),ROW()-1)"
            .Calculate
            brr = .Value
            .Value = brr
            Erase brr
        End With
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=.Parent.Cells(2, 1).Resize(UBound(arr, 1), 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange .Parent.Cells(2, 1).Resize(UBound(arr, 1), UBound(arr, 2) + 1)
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        brr = Application.Transpose(.Cells(2, 3).Resize(UBound(arr, 1), UBound(arr, 2) - 1))
        arr = Application.Transpose(.Cells(2, 2).Resize(UBound(arr, 1), 1))
    End With
    
    wb.Close False
    
    lo.DataBodyRange = brr
    lo.HeaderRowRange = arr
End Sub

Sub Макрос8()
Dim arr1 As Variant, arr2 As Variant, arr3 As Variant, arr4 As Variant
Dim n As Long, m As Long, i As Long
Set tabb = Worksheets("Лист1 (2)").ListObjects("Таблица18")
arr1 = tabb.Range
arr2 = Split(Range("Q1"), ", ")
ReDim arr3(LBound(arr1) To UBound(arr1) - 1, LBound(arr1, 2) To UBound(arr1, 2))
ReDim arr4(1 To 1, LBound(arr1, 2) To UBound(arr1, 2))
For n = LBound(arr2) To UBound(arr2)
    For m = LBound(arr1, 2) To UBound(arr1, 2)
        If arr2(n) = arr1(1, m) Then
        arr4(1, n + 1) = arr1(1, m)
            arr1(1, m) = ""
            For i = LBound(arr3) To UBound(arr3)
                arr3(i, n + 1) = arr1(i + 1, m)
            Next i
        End If
    Next m
Next n
For m = LBound(arr1, 2) To UBound(arr1, 2)
    If Not arr1(1, m) = "" Then
        arr4(1, n + 1) = arr1(1, m)
        For i = LBound(arr3) To UBound(arr3)
            arr3(i, n + 1) = arr1(i + 1, m)
        Next i
        n = n + 1
    End If
Next m
tabb.DataBodyRange = arr3
tabb.HeaderRowRange = arr4
End Sub