Delete row not equal to value in A1 for each sheet

[benntw]

My worksheet creates copied sheets from a list. The list is from the values in column C. What I want to do is after it copies and renames the sheet, search column C for values that don't match A1. A1 is the a formula to equal the sheet name. My data in column C starts on the 3rd row. Below is my code to copy and rename each sheet. The number of sheets depends on how many cost objects I have in my list. I hope someone can help on this. Thank you.

Sub CreateSheetsFromCostObjects()

Dim ws As Worksheet, Ct As Long, c As Range

Set ws = Worksheets("EditReport")

Application.ScreenUpdating = False

For Each c In Sheets("SheetNames").Range("A2:A40")
If c.Value <> "" Then
ws.Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = c.Value
Ct = Ct + 1
End If
Next c
If Ct > 0 Then
MsgBox Ct & " new sheets created from list"
Else
MsgBox "No names on list"
End If

Call CreateHyperlinks

Sheets("SheetNames").Select

Application.ScreenUpdating = True
End Sub

 

[benntw]

I do have the code from post #4 . I copied the entire code. Right after ActiveSheet.Name = c.Value it runs down the code and skips over If .Cells(i, "C").Value <> .Range("A1").Value Then .Cells(i, "C").EntireRow.Delete & Next i. The only difference between post #2 & #4 is the added code With ActiveSheet between Ct = Ct + 1 & For i = .Cells(.Rows.Count, "C").End(xlUp).Row To 3. I don't think I missed anything.

 

[shg]

For i = .Cells(.Rows.Count, "C").End(xlUp).Row To 3 [COLOR="#FF0000"]Step -1[/COLOR]

 

[benntw]

That did the trick. Thank you.

 

[JoeMo]

For i = .Cells(.Rows.Count, "C").End(xlUp).Row To 3 [COLOR=#FF0000]Step -1[/COLOR]

Thank you shg - I was too weary to notice that!

 

[benntw]

Joe , I really appreciate all the help you gave me. I have a question for you that you might cringe at haha. Would it be better to have all my sheets that are created from a list be blank ? Then each sheet could loop through the sheet with all the data and copy what matches from the value in A1 ? I am only asking this since my sheet has 6500 line items, and can change daily, and it takes about 10 minutes to delete all the rows that don't match A1. Before I added that part of the code it would create about 26 sheets in less than one minute. I was trying this morning to create a loop. The issue I was running into was referencing the active sheet added from the sheet that had all the data rows.

 

[JoeMo]

Don't know the answer to your question since it depends on several things that might vary from sheet to sheet. Deleting rows is a slow process, but there may be a way to speed it up in your case. Can you post the exact code you are using now?

 

[benntw]

Option Explicit

Sub CreateSheetsFromCostObjects()
Dim ws As Worksheet, Ct As Long, c As Range, i As Long
Set ws = Worksheets("EditReport")
Application.ScreenUpdating = False
For Each c In Sheets("SheetNames").Range("A2:A40")
If c.Value <> "" Then
ws.Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = c.Value
Ct = Ct + 1
With ActiveSheet
For i = .Cells(.Rows.Count, "C").End(xlUp).Row To 3 Step -1
If .Cells(i, "C").Value <> .Range("A1").Value Then .Cells(i, "C").EntireRow.Delete
Next i
End With
End If
Next c
If Ct > 0 Then
MsgBox Ct & " new sheets created from list"
Else
MsgBox "No names on list"
End If

Call CreateHyperlinks

Sheets("SheetNames").Select

Application.ScreenUpdating = True
End Sub

 

[JoeMo]

Using a sheet that "takes about 10 minutes to delete all the rows", see if this modification (untested) speeds things up.

Option Explicit
Sub CreateSheetsFromCostObjects2()
Dim ws As Worksheet, Ct As Long, c As Range, i As Long, V As Variant, x As Variant
Set ws = Worksheets("EditReport")
Application.ScreenUpdating = False
For Each c In Sheets("SheetNames").Range("A2:A40")
    If c.Value <> "" Then
        ws.Copy after:=Sheets(Sheets.Count)
        ActiveSheet.Name = c.Value
        Ct = Ct + 1
        With ActiveSheet
            x = .Range("A1").Value
            V = .Range("C3:C" & .Cells(.Rows.Count, "C").End(xlUp).Row).Value
            For i = LBound(V, 1) To UBound(V, 1)
                If V(i, 1) <> x Then V(i, 1) = "#N/A"
            Next i
            On Error Resume Next
            With .Range("C3:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
                .Value = V
                .SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
            End With
            On Error GoTo 0
        End With
    End If
Next c
If Ct > 0 Then
MsgBox Ct & " new sheets created from list"
Else
MsgBox "No names on list"
End If

Call CreateHyperlinks

Sheets("SheetNames").Select

Application.ScreenUpdating = True
End Sub

 

[benntw]

You are the master. Thank you very much ! That worked absolutely perfect !!!

 

[JoeMo]

You are the master. Thank you very much ! That worked absolutely perfect !!!

You are welcome. Care to share how long this version took to delete the pertinent rows when compared to the earlier version?