Here's a new version modified to allow for blank rows.

Option Explicit

Dim UniqueValues As New Collection

Function CountUniqueValues(InputRange As Range) As Long
Dim cl As Range
On Error Resume Next ' ignore any errors
For Each cl In InputRange
If cl.Value < "" Then UniqueValues.Add cl.Value,
CStr(cl.Value) ' add the unique item
Next cl
On Error GoTo 0
CountUniqueValues = UniqueValues.Count
End Function

Function FindLastCell() As Range
Dim LastColumn As Integer
Dim LastRow As Long
Dim LastCell As Range
If WorksheetFunction.CountA(Cells) 0 Then
'Search for any entry, by searching backwards by Rows.
LastRow = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
'Search for any entry, by searching backwards by Columns.
LastColumn = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Set FindLastCell = Cells(LastRow, LastColumn)
Else
Set FindLastCell = Range("A1")
End If
End Function

Sub FilterNames()
'Macro written 21_July_2006 By Die_Another_Day
Dim i As Long
Dim uCnt As Long 'Unique Values count
Dim hWS As Worksheet 'Home Worksheet
Dim nWS As Worksheet 'New Worksheet
Dim lCell As Range 'Last Cell
Dim fRange As Range 'Filter Range

Application.ScreenUpdating = False
Set hWS = ActiveSheet
Set lCell = FindLastCell
Set fRange = Range("A1", lCell)
uCnt = CountUniqueValues(fRange.Columns(1))
fRange.AutoFilter
For i = 1 To uCnt
fRange.AutoFilter Field:=1, Criteria1:=UniqueValues(i)
Range("A1").CurrentRegion.SpecialCells(xlCellTypeV isible).Copy
Set nWS = Worksheets.Add
nWS.Name = UniqueValues(i)
nWS.Range("A1").PasteSpecial xlPasteAll
hWS.Activate
Application.CutCopyMode = False
Next
fRange.AutoFilter
Application.ScreenUpdating = True
End Sub

HTH

Die_Another_Day