Sub blah()
'Application.ScreenUpdating = False 'include this line and the last line of this macro to speed it up
Set RngToFilter = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 11)
RngToFilter.Columns(10).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Sheet1").Range("Q1"), Unique:=True
Set AllCritRng = Sheets("Sheet1").Range("Q1").CurrentRegion
Set RngCrit = AllCritRng.Resize(2, 1)
For Each cll In Intersect(AllCritRng, AllCritRng.Offset(1)).Cells
RngCrit.Cells(2).Value = cll.Value
With Sheets.Add(After:=Sheets(Sheets.Count))
RngToFilter.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=RngCrit, CopyToRange:=.Range("A1"), Unique:=False
.Name = Left(cll.Value, 31)
.Columns("A:K").AutoFit
End With
Next cll
AllCritRng.Clear
'Application.ScreenUpdating = True 'include this line and the first line of this macro to speed it up
End Sub