Try this one
With headers in the first row of the range
Sub Copy_With_AdvancedFilter()
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim headerrow As Long
Dim str As String
Set ws1 = Sheets("Sheet1")
Set rng = ws1.Range("A1:Z1000")
'Use a Dynamic range name,
http://www.contextures.com/xlNames01.html#Dynamic
With ws1
rng.Columns(3).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
'You see that the last two columns of the worksheet are used to make a Unique list
'and add the CriteriaRange.(you can't use this macro if you use this columns)
Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value
For Each cell In .Range("IV2:IV" & Lrow)
.Range("IU2").Value = cell.Value
str = cell.Value
If SheetExists(str) = False Then
Set WSNew = Sheets.Add
On Error Resume Next
WSNew.Name = str
On Error GoTo 0
Else
Set WSNew = Sheets(str)
End If
headerrow = LastRow(WSNew) + 1
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=WSNew.Cells(LastRow(WSNew) + 1, 1), _
Unique:=False
If headerrow > 1 Then WSNew.Rows(headerrow).Delete
Next
.Columns("IU:IV").Clear
End With
End Sub
You must copy this two functions in the module also
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As Boolean
'Chip Pearson
On Error Resume Next
If WB Is Nothing Then Set WB = ThisWorkbook
SheetExists = CBool(Len(WB.Sheets(SName).Name))
End Function
