Extremely slow VBA code

[Queryman]

I have some code that does the job, but takes over twenty minutes to run. The code works on 10,000 lines of data on an excel tab and cleans it up (deleting some columns and also all teh blank rows etc and then moving it to a new tab), I do have application.screenupdating set to false and I have tried commenting different pieces of the code to figure out where the performance issue is, but I can't seem to narrow it down, any suggestions highly appreciated.

Sub cleanup()
Application.ScreenUpdating = False
Sheet2.Visible = True
Sheet2.Range("A1:F5000").ClearContents
Sheet1.Activate
DELETE_ROWS
Columns("H:O").Delete
Columns("A:B").Delete
Columns("G:G").Delete
DeleteEmptyRows Range("A1:F10000")
Cells.Select
Selection.Columns.AutoFit
Sheet2.Range("A1:F1").Value = Sheet1.Range("A1:F1").Value
Sheet2.Range("A1:F5000").Value = Sheet1.Range("A1:F5000").Value
Sheet1.Hyperlinks.Delete
ActiveSheet.DrawingObjects.Select
    Selection.Delete
Range("a1").Select
Sheet1.Range("A1:F10000").ClearContents
Sheet2.Activate
Rows("1:1").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlTop
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .ShrinkToFit = False
    .MergeCells = False
End With
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
Sheet2.Range("D2:D5000").Select
Selection.NumberFormat = "General"
Cells.Select
Selection.Columns.AutoFit
Sheet2.Range("F2:F5000").Select
Selection.NumberFormat = "0"
Cells.Select
Selection.Columns.AutoFit
ActiveSheet.UsedRange
Sheet1.Visible = xlSheetHidden
      Sheet2.Range("A:f").AutoFilter
Range("a1").Select
Application.ScreenUpdating = True
End Sub




Sub DELETE_ROWS()
    Dim Lrow As Long
    Dim CalcMode As Long
    Dim StartRow As Long
    Dim EndRow As Long
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
     With ActiveSheet
        .DisplayPageBreaks = False
        StartRow = 1
        EndRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        For Lrow = EndRow To StartRow Step -1
            If IsError(.Cells(Lrow, "B").Value) Then
          ElseIf .Cells(Lrow, "B").Value = "Notes:" Then .Rows(Lrow).Delete
 End If
        Next
    End With
End Sub




Sub DeleteEmptyRows(DeleteRange As Range)
Dim rCount As Long, r As Long
    If DeleteRange Is Nothing Then Exit Sub
    If DeleteRange.Areas.Count > 1 Then Exit Sub
    With DeleteRange
        rCount = .Rows.Count
        For r = rCount To 1 Step -1
            If Application.CountA(.Rows(r)) = 0 Then
                .Rows(r).EntireRow.Delete
            End If
        Next r
    End With
End Sub

Michael

 

[xlbo]

You are far better off NOT looping to delete rows

Have a think about the autofilter and whether you can use that instead to filter for empty rows and then delete in 1 block...

Also, have a look at the FAQs - especially Skivought's FAQ on how selecting and activating slow your code down.

As a general rule, if you have any code along the lines of

Range("A_Range").Select
Selection.Do_Stuff

it can be changed to:

Range("A_Range").Do_Stuff

Same goes for Activate - very rarely need to slect or activate anything

Rgds, Geoff

We could learn a lot from crayons. Some are sharp, some are pretty and some are dull. Some have weird names and all are different colours but they all live in the same box.

Please read FAQ222-2244 before you ask a question

 

[Queryman]

Thanks Geoff, I changed to code per your suggestiopn. It still takes 20 minutes to complete the macro.

Sub cleanup()
Application.ScreenUpdating = False
Sheet2.Visible = True
Sheet2.Range("A1:F10000").ClearContents
Sheet1.Range("A1").AutoFilter Field:=2, Criteria1:="Notes:"
Sheet1.Range("A1").CurrentRegion.Offset(1, 0).SpecialCells _
            (xlCellTypeVisible).EntireRow.Delete
Sheet1.Range("A1").AutoFilter Field:=2, Criteria1:="="
Sheet1.Range("A1").CurrentRegion.Offset(1, 0).SpecialCells _
            (xlCellTypeVisible).EntireRow.Delete
Sheet1.Range("A1").AutoFilter
Columns("H:O").Delete
Columns("A:B").Delete
Columns("G:G").Delete
Sheet2.Range("A1:F1").Value = Sheet1.Range("A1:F1").Value
Sheet2.Range("A1:F10000").Value = Sheet1.Range("A1:F10000").Value
Sheet1.Hyperlinks.Delete
ActiveSheet.DrawingObjects.Delete
Sheet1.Range("A1:F10000").ClearContents
Sheet2.Rows("1:1").HorizontalAlignment = xlCenter
    Sheet2.Rows("1:1").VerticalAlignment = xlTop
   Sheet2.Rows("1:1").WrapText = False
    Sheet2.Rows("1:1").Orientation = 0
    Sheet2.Rows("1:1").AddIndent = False
    Sheet2.Rows("1:1").ShrinkToFit = False
    Sheet2.Rows("1:1").MergeCells = False
Sheet2.Rows("1:1").Font.Bold = True
Sheet2.Rows("1:1").Font.Underline = xlUnderlineStyleSingle
Sheet2.Range("D2:D10000").NumberFormat = "General"
Sheet2.Range("F2:F10000").NumberFormat = "0"
Sheet2.Columns("A:A").Columns.AutoFit
ActiveSheet.UsedRange
Sheet1.Visible = xlSheetHidden
      Sheet2.Range("A:f").AutoFilter
Range("a1").Select
Application.ScreenUpdating = True
End Sub

Michael

 

[xlbo]

nothing in there that should be overly intensive

do you have lots of calculations in the spreadsheet ??

If so, turn them to manual for the duration

You may also be better off adding a temporary column with a formula to determine whether to delete a row - then filter on the result of that formula - excel may be having trouble doing the calculations to get the set of empty rows from your autofilter statement e.g.

Add a formula in column N which looks at the row and dtermines whether it should be deleted or not - make it a simple Y/N answer (Y for delete)
copy and paste values on that formula
Filter on column N = "Y"
then delete all rows nd then unfilter

Rgds, Geoff

We could learn a lot from crayons. Some are sharp, some are pretty and some are dull. Some have weird names and all are different colours but they all live in the same box.

Please read FAQ222-2244 before you ask a question

 

[firefytr]

Not really sure the exact layout of your data, but you could cut a few lines out of that code ...



Sub cleanup()
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Sheet2.Visible = True
Sheet2.Range("A1:F10000").ClearContents
Sheet1.Range("1:1").AutoFilter Field:=2, Criteria1:="Notes:", Operator:=xlOr, Criteria2:="="
'// Possible error point..
Sheet1.Range("A1").CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Columns("H:O,A:B,G:G").Delete
Sheet2.Range("A1:F10000").Value = Sheet1.Range("A1:F10000").Value
Sheet1.Hyperlinks.Delete
ActiveSheet.DrawingObjects.Delete
Sheet1.Range("A1:F10000").ClearContents
Sheet2.Rows("1:1").HorizontalAlignment = xlCenter
Sheet2.Rows("1:1").VerticalAlignment = xlTop
Sheet2.Rows("1:1").Font.Bold = True
Sheet2.Rows("1:1").Font.Underline = xlUnderlineStyleSingle
Sheet2.Range("D210000").NumberFormat = "General"
Sheet2.Range("F2:F10000").NumberFormat = "0"
Sheet2.Columns("A:A").Columns.AutoFit
Sheet1.Visible = xlSheetHidden
Sheet2.AutoFilterMode = False
Range("A1").Select
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

-----------
Regards,
Zack Barresse

 

[Queryman]

Thanks Geoff and Zack for your replies.



Michael