Sub StudentTranspose()
Dim dataread, datawrite(), cls()
Dim lr As Long, c As Long, lc As Long
Dim i As Long, j As Long, n As Long
Dim unq As Boolean
With Worksheets("Sheet1")
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A1:B" & lr).Sort key1:=.Range("A1"), Order1:=xlAscending, _
key2:=.Range("B1"), Order2:=xlAscending, Header:=xlYes
dataread = .Range("A1:B" & lr)
End With
ReDim cls(1 To 26, 1 To 2) 'A to Z
cls(1, 1) = dataread(2, 1) 'first class
cls(1, 2) = 1 'counter
c = 1
For i = 3 To lr
unq = True
For j = 1 To c
If cls(j, 1) = dataread(i, 1) Then
unq = False
cls(j, 2) = cls(j, 2) + 1
If lc < cls(j, 2) Then lc = cls(j, 2)
Exit For
End If
Next j
If unq Then
c = c + 1
cls(c, 1) = dataread(i, 1)
End If
Next i
ReDim datawrite(1 To c + 2, 1 To lc + 2)
datawrite(1, 1) = dataread(1, 1)
For n = 2 To c + 1 'fill Class Names
datawrite(n, 1) = cls(n - 1, 1)
cls(n - 1, 2) = 1 'reset
Next n
For n = 1 To lc 'fill student name headers
datawrite(1, n + 1) = "Student" & n
Next n
datawrite(2, 2) = dataread(2, 2)
For i = 3 To lr 'read counter
For j = 1 To c
If cls(j, 1) = dataread(i, 1) Then
datawrite(j + 1, cls(j, 2) + 1) = dataread(i, 2)
cls(j, 2) = cls(j, 2) + 1
End If
Next j
Next i
Worksheets("Sheet2").Range("A1").Resize(c + 1, lc) = datawrite
End Sub