Sub Sort_ID()
    Dim lr&, fr&, r As Range
    fr = Range("A8").Row: lr = Cells(Rows.Count, "A").End(xlUp).Row
    Set r = Range("A" & fr & ":W" & lr)
    With r: .Sort .Cells(1, 1): End With
End Sub

Sub Заплывы()
    Dim d, i&, k&, lr&, fr&, r As Range
    fr = Range("A8").Row: lr = Cells(Rows.Count, "A").End(xlUp).Row
    Set r = Range("A" & fr & ":W" & lr)
    d = InputBox("Сколько дорожек в бассейне"): If d = 0 Or d > 8 Then Exit Sub
    [B3] = d

    Application.ScreenUpdating = 0
    With r
        .Sort .Cells(1, "C"), , .Cells(1, "F"), , , .Cells(1, "L")

        .Cells(1, "W") = 1: k = 1
        For i = 1 To lr - fr + 1
            If .Cells(i, "F") <> .Cells(i + 1, "F") Or k >= d Then 'вспомогательный столбец W
                k = 1: .Cells(i + 1, "W") = k
                If .Cells(i, "W") = 1 Then .Cells(i, "W") = 2: .Cells(i - 1, "W") = 1 'исключение одиночного заплыва
            Else
                k = k + 1: .Cells(i + 1, "W") = k
            End If

            Select Case .Cells(i, "W")    'дорожки
            Case 1: .Cells(i, "U") = 3
            Case 2: .Cells(i, "U") = 4
            Case 3: .Cells(i, "U") = 2
            Case 4: .Cells(i, "U") = 5
            Case 5: .Cells(i, "U") = 1
            Case 6: .Cells(i, "U") = 6
            End Select
        Next
        .Cells(i, "W") = "" 'затереть лишнее окончание

        .Cells(1, "V") = 1: k = 1 'заплыв
        For i = 2 To lr - fr + 1
            .Cells(i, "V") = k
            If .Cells(i, "W") = 1 Then k = k + 1: .Cells(i, "V") = k
        Next
    End With
End Sub