Sub sortirovka()
Dim i&, y&, lstr&
Application.ScreenUpdating = 0
lstr = Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
For i = 1 To lstr
    Cells(i, 9) = Split(Cells(i, 1), " ")(0)
    Cells(i, 10) = Mid(Cells(i, 1), InStr(Cells(i, 1), " ") + 1, 20)
    If Cells(i, 9) <> Cells(i - 1, 9) Then
        y = y + 1
        Cells(i, 8) = y
    Else
        Cells(i, 8) = y
    End If
Next
With ActiveWorkbook.Worksheets("Лист1").Sort
    .SortFields.Add Key:=Range("H1:H" & lstr), Order:=1
    .SortFields.Add Key:=Range("J1:J" & lstr), Order:=1
    .SetRange Range("B1:J" & lstr)
    .Apply
End With
For i = 1 To lstr
    Cells(i, 1) = Cells(i, 9) & " " & Cells(i, 10)
Next
Columns("H:J").ClearContents
Application.ScreenUpdating = 1
End Sub