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" <(E-Mail Removed)> wrote in message
news:489119CC-FB3A-4803-8A4C-(E-Mail Removed)...
> 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
|
Similar Threads
