Code Generates too Slow

[deanz]

I am running a macro that is designed to clean up unused lines in my template. The code does exactly what i want it to do... but it takes so darn to run it... i will probably end up with an answer before its done running. (LOL)..

Can anyone assist in the below code with a different way of going about what i did below that may result in quicker running?

Sub Clean_Up_CVG()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False


    RowA = 6
    Do Until Len(Sheets("E-Mail").Range("B" & RowA).Value) = 0
    If Sheets("E-Mail").Range("B" & RowA).Value = 0 Then
    Sheets("E-Mail").Rows(RowA).Delete Shift:=xlUp
    Else
    Sheets("E-Mail").Rows(RowA).Value = Sheets("E-Mail").Rows(RowA).Value
    RowA = RowA + 1
    End If
    Loop
    
    RowA = 6
    Do Until Len(Sheets("MON Summary").Range("B" & RowA).Value) = 0
    If Sheets("MON Summary").Range("B" & RowA).Value = 0 Then
    Sheets("MON Summary").Rows(RowA).Delete Shift:=xlUp
    Else
    Sheets("MON Summary").Rows(RowA).Value = Sheets("MON Summary").Rows(RowA).Value
    RowA = RowA + 1
    End If
    Loop
    
    RowA = 6
    Do Until Len(Sheets("SCI Summary").Range("B" & RowA).Value) = 0
    If Sheets("SCI Summary").Range("B" & RowA).Value = 0 Then
    Sheets("SCI Summary").Rows(RowA).Delete Shift:=xlUp
    Else
    Sheets("SCI Summary").Rows(RowA).Value = Sheets("SCI Summary").Rows(RowA).Value
    RowA = RowA + 1
    End If
    Loop
    
    RowA = 6
    Do Until Len(Sheets("CMON Summary").Range("B" & RowA).Value) = 0
    If Sheets("CMON Summary").Range("B" & RowA).Value = 0 Then
    Sheets("CMON Summary").Rows(RowA).Delete Shift:=xlUp
    Else
    Sheets("CMON Summary").Rows(RowA).Value = Sheets("CMON Summary").Rows(RowA).Value
    RowA = RowA + 1
    End If
    Loop
    
    RowA = 6
    Do Until Len(Sheets("Specialty Summary").Range("B" & RowA).Value) = 0
    If Sheets("Specialty Summary").Range("B" & RowA).Value = 0 Then
    Sheets("Specialty Summary").Rows(RowA).Delete Shift:=xlUp
    Else
    Sheets("Specialty Summary").Rows(RowA).Value = Sheets("Specialty Summary").Rows(RowA).Value
    RowA = RowA + 1
    End If
    Loop
    
    RowA = 6
    Do Until Len(Sheets("Brand Service Summary").Range("B" & RowA).Value) = 0
    If Sheets("Brand Service Summary").Range("B" & RowA).Value = 0 Then
    Sheets("Brand Service Summary").Rows(RowA).Delete Shift:=xlUp
    Else
    Sheets("Brand Service Summary").Rows(RowA).Value = Sheets("Brand Service Summary").Rows(RowA).Value
    RowA = RowA + 1
    End If
    Loop
    
    RowA = 6
    Do Until Len(Sheets("Brand Sales Summary").Range("B" & RowA).Value) = 0
    If Sheets("Brand Sales Summary").Range("B" & RowA).Value = 0 Then
    Sheets("Brand Sales Summary").Rows(RowA).Delete Shift:=xlUp
    Else
    Sheets("Brand Sales Summary").Rows(RowA).Value = Sheets("Brand Sales Summary").Rows(RowA).Value
    RowA = RowA + 1
    End If
    Loop
    
    RowA = 6
    Do Until Len(Sheets("Agent Summary").Range("B" & RowA).Value) = 0
    If Sheets("Agent Summary").Range("B" & RowA).Value = 0 Then
    Sheets("Agent Summary").Rows(RowA).Delete Shift:=xlUp
    Else
    Sheets("Agent Summary").Rows(RowA).Value = Sheets("Agent Summary").Rows(RowA).Value
    RowA = RowA + 1
    End If
    Loop
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True


    
End Sub

 

[Rick Rothstein]

You appear to be deleting empty cells in Column B on several (named) sheets and converting the not blank cells containing formulas to constants... is that correct?

 

[deanz]

Thanks Rick!

Yes... Column "B" is more the criteria piece of it... i have it looking in column B for a zero in the cell. The way the template is setup.. .this is the name column.. and when it hits zero.. all rows from there down with a zero in column "B" the row will be deleted.

DeanZ

 

[Fluff]

Whilst I'm sure that Rick can come up with something better, try this

Sub Clean_Up_CVG()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False


    With Sheets("E-Mail")
        .UsedRange.Value = .UsedRange.Value
        With .Range("B6", .Range("B" & Rows.Count).End(xlUp))
            .Replace 0, "", xlWhole
            .SpecialCells(xlBlanks).EntireRow.Delete
        End With
    End With
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True


    
End Sub

You can then expand it to your other sheets, if it works

 

[Rick Rothstein]

Thanks Rick!

Yes... Column "B" is more the criteria piece of it... i have it looking in column B for a zero in the cell. The way the template is setup.. .this is the name column.. and when it hits zero.. all rows from there down with a zero in column "B" the row will be deleted.

First, what is in Column B on those sheets... formulas or constants?

Second, what is displayed in Column B cells... text, not a number, correct? And when you say "hits zero" you mean the length of the text in the column is 0 (the cell itself is displaying a blank cell), correct?

Third, was I correct in my previous message in assuming you are converting all formulas on the worksheet (not just Column B) to constants?

 

[deanz]

FLUFF!!! You are a genius!!! This worked perfectly.. what was taking excel more than 30 minutes to accomplish is now happening in less than a minute for 5 different templates! Thank you so much! You don't know how much this has helped me! Thanks Again!

DeanZ

 

[Fluff]

Glad to help & thanks for the feedback.

Also, rather than writing the same thing for each sheet you can do this, where the parts in red are your sheet names

Sub Clean_Up_CVG()

    Dim Arr As Variant
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False


    For Each Arr In Array("[COLOR=#ff0000]Sheet3[/COLOR]", "[COLOR=#ff0000]PP[/COLOR]", "[COLOR=#ff0000]UIL[/COLOR]")
        With Sheets(Arr)
            .UsedRange.Value = .UsedRange.Value
            With .Range("B6", .Range("B" & Rows.Count).End(xlUp))
                .Replace 0, "", xlWhole
                .SpecialCells(xlBlanks).EntireRow.Delete
            End With
        End With
    Next Arr
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True


    
End Sub