This macro will alphabetize the student roster, if it's not already, and uses a "one pass per student" loop that should be peppy on larger data sets since you're not going cell by cell. Also, your sample didn't show data in row1, so mine adds a title row. We can delete that if there are titles already.
Sub ReorganizeStudents()
Dim LC As Long, i As Long, wsOut As Worksheet
Application.ScreenUpdating = False
Set wsOut = Sheets("Sheet2")
Rows(1).Insert xlShiftDown
Range("A1") = "key"
Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
Range("AA:AA").Sort Key1:=Range("AA2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Range("AA2:AA" & Rows.Count).SpecialCells(xlCellTypeConstants).Copy
wsOut.Range("A1").PasteSpecial xlPasteAll, Transpose:=True
Range("AA:AA").Clear
LC = wsOut.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To LC
Range("A:A").AutoFilter 1, wsOut.Cells(1, i)
Range("B2", Range("B2").End(xlDown)).Copy wsOut.Cells(2, i)
Next i
ActiveSheet.AutoFilterMode = False
Rows(1).Delete xlShiftUp
wsOut.Activate
Application.ScreenUpdating = True
End Sub
How/Where to install the macro:
1. Open up your workbook
2. Get into VB Editor (Press Alt+F11)
3. Insert a new module (Insert > Module)
4. Copy and Paste in your code (given above) to this new module
5. Get out of VBA (Press Alt+Q)
6. Save your sheet
The macro is installed and ready to use. Press Alt-F8 and select it from the macro list.
Will create the list on Sheet2. Works well on your sample sheet.
Bookmarks