How can I automate creating a sheet for a unique value that is bla



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("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, _

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"

End If
On Error GoTo 0

rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=wsNew.Range("A1"), _
' 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
End With

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

Norman Jones

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!

Dave Peterson

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.

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question