```
Sub ExtractStudents()
Dim d As Object, c As Variant, i As Long, lr As Long, ws As Worksheet, lr2 As Long, WS2 As Worksheet
Dim a As Long, j As Long, e As Long
Set ws = Sheets("data")
Set d = CreateObject("Scripting.Dictionary")
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lr).Sort , key1:=Range("B2:B" & lr), order1:=xlAscending, key2:=Range("A2:A" & lr), order2:=xlAscending, Header:=xlNo
c = Range("B2:B" & lr)
For i = 1 To UBound(c, 1)
d(c(i, 1)) = 1
Next i
ws.Range("E1").Value = "Unique"
ws.Range("E2").Resize(d.Count) = Application.Transpose(d.keys)
lr2 = ws.Cells(Rows.Count, 5).End(xlUp).Row
Range("E2:E" & lr2).Sort , key1:=Range("E2:E" & lr2), order1:=xlAscending, Header:=xlNo
For i = 2 To lr2
ws.Range("F" & i) = i - 1
Next i
For i = 2 To lr2
If ws.Cells(i, 5).Value <> "" Then
a = Application.WorksheetFunction.CountIf(ws.Range("D2:D" & lr), ws.Cells(i, 6))
For j = 2 To lr
If ws.Cells(j, 2).Value <> "" Then
ws.Cells(j, 3).Value = Application.WorksheetFunction.CountIf(ws.Range("D2:D" & j), ws.Range("F" & i))
End If
Next j
Sheets.Add(After:=Sheets(Sheets.Count)).Name = ws.Cells(i, 5).Value
Cells(1, 3).Value = ws.Cells(i, 5).Value
For j = 2 To a + 1
Range("A" & j).Value = Application.WorksheetFunction.Index(ws.Range("A2:A" & lr), Application.WorksheetFunction.Match(j - 1, ws.Range("C2:C" & lr), 0), 1)
Next j
Range("A2:A" & a + 1).Sort , key1:=Range("A2:A" & a + 1), order1:=xlAscending, Header:=xlNo
Columns("A").AutoFit
End If
Next i
Range("C1:C" & lr).ClearContents
Range("E1:F" & lr).ClearContents
End Sub
```