Sub Dic_Col_PereborStudentov()
'(словарь коллекций)
'КЛЮЧ - по студенту и номеру зачётки (словарь)
'ЗНАЧЕНИЕ - по предмету, дате, аудитории, баллу (коллекция)
Dim a, i&, t$, Dic As Object
Dim el, col
With Application: .ScreenUpdating = False: .EnableEvents = False: .DisplayAlerts = False: .Calculation = xlManual: End With

'удаление листа PT если есть
On Error Resume Next
ThisWorkbook.Sheets("PT").Delete
On Error GoTo 0

'задание исходного массива
With ThisWorkbook.Sheets("1234")
    LR = .Cells(.Rows.Count, "A").End(xlUp).Row
    a = .Range("A1:I" & LR).Value
End With    

'формирование словаря
Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        .CompareMode = 1
        For i = 1 To UBound(a)
            t = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5)
            If Not .exists(t) Then
                .Add t, New Collection
                .Item(t).Add a(i, 6) & "|" & a(i, 7) & "|" & a(i, 8) & "|" & a(i, 9)
            Else
                .Item(t).Add a(i, 6) & "|" & a(i, 7) & "|" & a(i, 8) & "|" & a(i, 9)
            End If
        Next
    End With

 'выгрузка     
    With ThisWorkbook.Worksheets.Add
    .Name = "PT"
    For Each el In Dic.keys    
        Debug.Print "СТУДЕНТ " & el
        For Each col In Dic.Item(el)
            Debug.Print "ПРЕДМЕТ " & col
        Next
    Next
    End With
'..................
With Application: .ScreenUpdating = True: .EnableEvents = True: .DisplayAlerts = True: .Calculation = xlAutomatic: End With
End Sub