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

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

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!
 
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.
 
Back
Top