Try
Sub test()
Dim e
With Sheets("sheet1").Cells(1).CurrentRegion
.Parent.AutoFilterMode = False
For Each e In Filter(.Parent.Evaluate("transpose(if(countif(offset(" & _
.Columns(2).Offset(1).Address & ",0,0,row(1:" & .Rows.Count & "))," & _
.Columns(2).Offset(1).Address & ")=1," & .Columns(2).Offset(1).Address & _
",char(2)))"), Chr(2), 0)
If Not IsSheetExists(CStr(e)) Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = e
End If
Sheets(CStr(e)).Cells.Clear
.AutoFilter 2, e
.Copy Sheets(CStr(e)).Cells(1)
.AutoFilter
Next
End With
End Sub
Function IsSheetExists(ByVal txt As String) As Boolean
On Error Resume Next
IsSheetExists = Len(Sheets(txt).Name)
On Error GoTo 0
End Function
Bookmarks