Try this
Option Explicit

'---------------------------------------------------------------------------------------
' Module    : Module1
' DateTime  : 24/09/2006 22:48
'           : 30/06/2011 adapted to copy sheets to individual workbooks
' Author    : Roy Cox (royUK)
' Website   :  more examples
' Purpose   :  Create a sheet for each unique name in data & move to new workbook
' Disclaimer; This code is offered as is with no guarantees. You may use it in your
'             projects but please leave this header intact.
'---------------------------------------------------------------------------------------

Sub ExtractToSheets()
    Dim ws As Worksheet
    Dim wsNew As Worksheet
    Dim rData As Range
    Dim rCl As Range
    Dim sNm As String
    Set ws = Sheet1

    'extract a list of unique names
    'first clear existing list
    With ws
        Set rData = .Cells(1, 1).CurrentRegion
        .Columns(.Columns.Count).Clear
        rData.Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True

        For Each rCl In .Range(.Cells(2, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
            sNm = rCl.Text
            'add new sheet (only if required-NB uses UDF)
            Set wsNew = Sheets.Add
            wsNew.Name = sNm
            'AutoFilter & copy to relevant sheet
            rData.AutoFilter Field:=1, Criteria1:=sNm
            rData.Copy Destination:=Worksheets(sNm).Cells(1, 1)
            Sheets(sNm).Copy    'create new workbook
            ActiveWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & sNm & ".xlsx"
            ActiveWorkbook.Close
            Application.DisplayAlerts = False
            Sheets(sNm).Delete    'create new workbook
            Application.DisplayAlerts = True
        Next rCl
    End With
    ws.Columns(Columns.Count).ClearContents        'remove temporary list
    rData.AutoFilter        'switch off AutoFilter
End Sub