Hi,
Please assist.

Below sorts, filters, creates a sheet for each unique value except for the
blank cells on the filtered column.
How can I create a sheet for the rows that are blank?


Sub FilterValue()


Dim CalcMode As Long
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
' Dim rng2 As Range
Dim cell As Range
Dim Lrow As Long
'Dim Lr As Long


Range("F10").Select
Range("A1:G2870").Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:= _
Range("D2"), Order2:=xlAscending, Key3:=Range("B2"),
Order3:=xlAscending _
, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, _
DataOption3:=xlSortNormal

Set ws1 = Sheets("Data")
Set rng = ws1.Range("A1").CurrentRegion

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With ws1
rng.Columns(6).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True


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
'If SheetExists(cell.Value) = False Then
Set wsNew = Sheets.Add
On Error Resume Next
wsNew.Name = cell.Value


If Err.Number 0 Then
MsgBox "Change the name of: " & wsNew.Name & " manually"
Err.Clear

End If
On Error GoTo 0

rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
wsNew.Columns.AutoFit
' Else
' Set wsNew = Sheets(cell.Text)
' Lr = LastRow(ws2)
'' rng.AdvancedFilter Action:=xlFilterCopy, _
' CriteriaRange:=.Range("IU1:IU2"), _
' CopyToRange:=wsNew.Range("A" & Lr + 1), _
' Unique:=False
'ws2.Range("A" & Lr + 1).EntireRow.Delete
' End If
Next
.Columns("IU:IV").Clear
End With

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub

Hi Gwen,

You want to add a sheet for all blank cells in the filter column?

Try something like:

Dim rng2 As Range
Dim i As Long

On Error Resume Next
Set rng2 = rng.Columns(6).SpecialCells(xlBlanks)
On Error GoTo 0

If Not rng2 Is Nothing Then
For i = 1 To rng2.Cells.Count
Worksheets.Add after:=Sheets(Sheets.Count)
Next i
End If


However, I may well have failed to understand your requirements!



---
Regards,
Norman


"Gwen" wrote in message
...
Hi,
Please assist.

Below sorts, filters, creates a sheet for each unique value except for the
blank cells on the filtered column.
How can I create a sheet for the rows that are blank?


Sub FilterValue()


Dim CalcMode As Long
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
' Dim rng2 As Range
Dim cell As Range
Dim Lrow As Long
'Dim Lr As Long


Range("F10").Select
Range("A1:G2870").Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:= _
Range("D2"), Order2:=xlAscending, Key3:=Range("B2"),
Order3:=xlAscending _
, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=
_
xlTopToBottom, DataOption1:=xlSortNormal,
DataOption2:=xlSortNormal, _
DataOption3:=xlSortNormal

Set ws1 = Sheets("Data")
Set rng = ws1.Range("A1").CurrentRegion

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With ws1
rng.Columns(6).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True


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
'If SheetExists(cell.Value) = False Then
Set wsNew = Sheets.Add
On Error Resume Next
wsNew.Name = cell.Value


If Err.Number 0 Then
MsgBox "Change the name of: " & wsNew.Name & " manually"
Err.Clear

End If
On Error GoTo 0

rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
wsNew.Columns.AutoFit
' Else
' Set wsNew = Sheets(cell.Text)
' Lr = LastRow(ws2)
'' rng.AdvancedFilter Action:=xlFilterCopy, _
' CriteriaRange:=.Range("IU1:IU2"), _
' CopyToRange:=wsNew.Range("A" & Lr + 1),
_
' Unique:=False
'ws2.Range("A" & Lr + 1).EntireRow.Delete
' End If
Next
.Columns("IU:IV").Clear
End With

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub

How about changing the blank cells to BLANK, run the rest of the code and then
fix the BLANKs in both locations.

Just a couple (ok, three) edit|replaces sounds like it would be enough.

Gwen wrote:

Hi,
Please assist.

Below sorts, filters, creates a sheet for each unique value except for the
blank cells on the filtered column.
How can I create a sheet for the rows that are blank?

Sub FilterValue()


Dim CalcMode As Long
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
' Dim rng2 As Range
Dim cell As Range
Dim Lrow As Long
'Dim Lr As Long


Range("F10").Select
Range("A1:G2870").Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:= _
Range("D2"), Order2:=xlAscending, Key3:=Range("B2"),
Order3:=xlAscending _
, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, _
DataOption3:=xlSortNormal

Set ws1 = Sheets("Data")
Set rng = ws1.Range("A1").CurrentRegion

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With ws1
rng.Columns(6).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True


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
'If SheetExists(cell.Value) = False Then
Set wsNew = Sheets.Add
On Error Resume Next
wsNew.Name = cell.Value


If Err.Number 0 Then
MsgBox "Change the name of: " & wsNew.Name & " manually"
Err.Clear

End If
On Error GoTo 0

rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
wsNew.Columns.AutoFit
' Else
' Set wsNew = Sheets(cell.Text)
' Lr = LastRow(ws2)
'' rng.AdvancedFilter Action:=xlFilterCopy, _
' CriteriaRange:=.Range("IU1:IU2"), _
' CopyToRange:=wsNew.Range("A" & Lr + 1), _
' Unique:=False
'ws2.Range("A" & Lr + 1).EntireRow.Delete
' End If
Next
.Columns("IU:IV").Clear
End With

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub

--

Dave Peterson