auto filter blanks

[austenr]

Im running a routine where the macro filters on column D for unique records. This works perfect except at the end where it filters on blanks and tries to create another sheet. The code is below. How do you get around not trying to create a worksheet for blanks?

Sub NewWorksheetForEachDept()
'Splits the MasterFile into separate worksheets for emailing
Dim WBO As Workbook
Dim ThisWS
Dim rngFilter As Range 'filter range
Dim rngUniques As Range 'Unique Range
Dim cell As Range
Dim counter As Integer
Dim rngResults As Range 'filter range
Sheets("Summary-Schedule").Select
Set WBO = ThisWorkbook
'Sheets("Summary-Schedule").Select
Set rngFilter = Range("D1", Range("D" & Rows.Count).End(xlUp))
Set rngResults = Range("A1", Range("K" & Rows.Count).End(xlUp))


With rngFilter
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUniques = Range("D2", Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)


ActiveSheet.ShowAllData


End With




For Each cell In rngUniques
Worksheets.Add After:=Worksheets(Worksheets.Count)
If cell.Value = "" Then
   Exit Sub
Else
ThisWS = cell.Value
ActiveSheet.Name = ThisWS
'counter = counter + 1
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
'rngFilter.SpecialCells(xlCellTypeVisible).Copy Destination:=WBO.Sheets(ThisWS).Range("A1")
rngResults.SpecialCells(xlCellTypeVisible).Copy Destination:=WBO.Sheets(ThisWS).Range("A1")
End If
Next cell


rngFilter.Parent.AutoFilterMode = False


End Sub

[p45cal]

move the line:
Worksheets.Add After:=Worksheets(Worksheets.Count)
after:
Else
.