Split Single Worksheet Into Multiple Workbooks

Sub Test()
    Const xlColumnWidths = 8
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim c As Range
    Dim List As New Collection
    Dim Item As Variant
    Dim WB As Workbook
    Application.ScreenUpdating = False
''   *** Change Sheet name to suit ***
    Set Sh = Worksheets("Sheet1")
    Set Rng = Sh.Range("A2:A" & Sh.Range("A65536").End(xlUp).Row)
    On Error Resume Next
    For Each c In Rng
        List.Add c.Value, CStr(c.Value)
    Next c
    On Error GoTo 0
    Set Rng = Sh.Range("A1:H" & Sh.Range("A65536").End(xlUp).Row)
    For Each Item In List
        Set WB = Workbooks.Add
        Sh.Cells.Copy
        WB.Worksheets(1).Range("A1").PasteSpecial Paste:=xlColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        Rng.AutoFilter Field:=1, Criteria1:=Item
        Rng.SpecialCells(xlCellTypeVisible).Copy WB.Worksheets(1).Range("A1")
        Rng.AutoFilter
        With WB
            .SaveAs ThisWorkbook.Path & "\" & Item & ".xls"
            .Close
        End With
    Next Item
    Sh.Activate
    Application.ScreenUpdating = True
End Sub