Ken

I think that this is the solution you need. However, if
there are more than 255 different items in the original
list you will get a subscript out of range message.

I could do this but you probably need the solution
quickly. Copy from option Explicit into a module

Regards
Peter

Option Explicit
Dim i As Long, nr As Long, nr2 As Long, j As Integer

Sub Test()
Dim r As Long
Dim v As Variant, c As Variant
Dim rng As Range, dest As Range
Dim wks As Worksheet
Dim nwks As Integer
Application.ScreenUpdating = False
Worksheets(1).Select
'Find how many rows in worksheet 1
nr = Sheets("Sheet1").UsedRange.Rows.Count
Set rng = Range(Cells(1, 1), Cells(nr, 1))
On Error Resume Next
For Each c In rng
' Test the previous row & add sheet if not the same
If c < c.Offset(-1, 0) Then
Addsheet
'this line does not work
nwks = Worksheets.Count
r = Application.WorksheetFunction.CountA(Worksheets
(nwks) _
.Range("A:A")) + 1
Set dest = Worksheets(nwks).Cells(r, 1)
Range(c.Offset(, 0), c.Offset(, 4)).Copy dest
ElseIf c = c.Offset(-1, 0) Then
nwks = Worksheets.Count
r = Application.WorksheetFunction.CountA(Worksheets
(nwks) _
.Range("A:A")) + 1
Set dest = Worksheets(nwks).Cells(r, 1)
Range(c.Offset(, 0), c.Offset(, 4)).Copy dest
End If
Next c
InsrtRows
Application.ScreenUpdating = True
Worksheets(1).Select
End Sub

Sub InsrtRows()
Dim nwks As Integer
nwks = Worksheets.Count
For i = 2 To nwks
Worksheets(i).Select
Range("A1:A3").Select
Selection.EntireRow.Insert
NameSheet
Next i
End Sub

Sub NameSheet()
Dim Titles()
Titles = Array("Name", "ID", "Amt")
Range("A1:A3") = Application.WorksheetFunction.Transpose
(Titles)
With ActiveSheet
.Name = Range("A4")
End With
End Sub

Sub Addsheet()
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
End Sub