Parsing out file into multiple new files

1) Move the DATA you already have in column AA over to column W, or some other empty column. The macro is using column AA to create the unique list of Directors.

2) In case you run the macro multiple times, probably a good idea to erase the named ranges the Advanced Filter creates.

3) I've updated the code to no longer "select" sheets, unneeded.

Option Explicit

Sub ParseStudents()
'JBeaucaire  (11/11/2009)
'Based on column C, data is filtered to individual sheets
'Creates sheets and sorts alphabetically in workbook
Dim LR As Long, i As Long, MyArr
Dim MyCount As Long, ws As Worksheet
Application.ScreenUpdating = False

Set ws = Sheets("Original")

With ws
    On Error Resume Next
    .Range("Criteria").Name.Delete
    .Range("Extract").Name.Delete
    On Error GoTo 0
    .Columns("E:E").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("AA1"), Unique:=True
    .Columns("AA:AA").Sort Key1:=.Range("AA2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    MyArr = Application.WorksheetFunction.Transpose(.Range("AA2:AA" & Rows.Count).SpecialCells(xlCellTypeConstants))
    
    .Range("AA:AA").Clear
    .Range("A1:K1").AutoFilter
    
    For i = 1 To UBound(MyArr)
        .Range("A1:K1").AutoFilter Field:=5, Criteria1:=MyArr(i)
        LR = .Range("A" & .Rows.Count).End(xlUp).Row
        If LR > 1 Then
            If Not Evaluate("=ISREF('" & MyArr(i) & "'!A1)") Then
                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(i)
            Else
                Sheets(MyArr(i)).Move After:=Sheets(Sheets.Count)
                Sheets(MyArr(i)).Cells.Clear
            End If
            .Range("A1:K" & LR).Copy Sheets(MyArr(i)).Range("A1")
            .Range("A1:K1").AutoFilter Field:=1
            MyCount = MyCount + Sheets(MyArr(i)).Range("A" & Rows.Count).End(xlUp).Row - 1
            Sheets(MyArr(i)).Columns.AutoFit
        End If
    Next i
    .AutoFilterMode = False
    LR = .Range("A" & .Rows.Count).End(xlUp).Row - 1
    .Activate
End With

MsgBox "Rows with data: " & LR & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub