Sub blah()
Dim Response As Range
On Error Resume Next
Set Response = Application.InputBox("Select any cell in the column you want filtered new sheets for", "Select a column", "$I$1", , , , , 8)
On Error GoTo here
If Not Response Is Nothing Then
Application.ScreenUpdating = False
Set OrigSht = Response.Parent
With OrigSht
Set Response = .Cells(1, Response.Column)
Set RangeToFilter = Intersect(.UsedRange, Response.EntireColumn)
'Set RangeToFilterData = RangeToFilter.Offset(1).Resize(RangeToFilter.Rows.Count - 1)
Set uniqueSht = Sheets.Add(After:=Sheets(Sheets.Count))
RangeToFilter.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=uniqueSht.Range("A1"), Unique:=True
Set uniquerng = uniqueSht.UsedRange
For Each cll In uniquerng
cll.Value = Application.Trim(cll.Value)
If Len(cll.Value) = 0 Then cll.Value = " "
Next cll
uniquerng.RemoveDuplicates Columns:=1, Header:=xlYes
Set uniquerng = uniqueSht.UsedRange
Set uniquerng = uniquerng.Offset(1).Resize(uniquerng.Rows.Count - 1)
For Each cll In uniquerng
RangeToFilter.AutoFilter Field:=1, Criteria1:=cll.Value
Set newsht = Sheets.Add(After:=Sheets(Sheets.Count))
OrigSht.UsedRange.Copy
newsht.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
OrigSht.UsedRange.Copy newsht.Range("A1")
'get new sheet name:
newshtName = Application.Trim(Response.Value & " " & IIf(cll.Value = " ", "(blanks)", cll.Value))
'remove illegal sheet name characters:
For i = 1 To 7
newshtName = Replace(newshtName, Mid(":\/?*[]", i, 1), vbNullString)
Next i
'name the sheet:
newsht.Name = Right(newshtName, 31)
Next cll
End With
RangeToFilter.AutoFilter
Application.DisplayAlerts = False
uniqueSht.Delete
Application.DisplayAlerts = True
MsgBox "Done"
End If
here:
Application.ScreenUpdating = True
End Sub