Make this code more efficient

[HWL]

I have a macro that works fine except this piece of it which dramatically slows down. The spread sheet it is applying to has about 3000 rows of data.

This piece of code is simply trying to format the sheet; set freeze panes, make font consistent, autofit rows/cols, and delete blank rows. Is there someone who could re-write it to dramatically increase the speed? THANKS

Application.StatusBar = "****Please Wait***** Formatting " & Sheets(1).Name
Sheets(1).Activate
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 12
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
End With
'deletes blank rows
Dim LastRow1 As Long, i As Long
LastRow1 = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For i = LastRow1 To 1 Step -1 'row 1 is the header row.
With Rows(i)
If Application.WorksheetFunction.CountBlank(.Cells) = .Cells.Count Then .EntireRow.Delete
End With
Next i
'end blank row code

 

[shg]

Try setting calculation to manual and screenupdating to false before deleting the rows, and then restore them when you're done.

 

[shg]

Sub x()
    Dim wks         As Worksheet
    Dim bUpd        As Boolean
    Dim iCalc       As XlCalculation
    Dim rRow        As Range
 
    Set wks = Worksheets(1)
 
    With wks
        Application.StatusBar = "****Please Wait***** Formatting " & wks.Name
        Application.Goto wks.Rows(2)
        ActiveWindow.FreezePanes = True
 
        With .Cells.Font
            .Name = "Arial"
            .Size = 12
        End With
 
        .Columns.AutoFit
        .Rows.AutoFit
 
        bUpd = Application.ScreenUpdating
        Application.ScreenUpdating = False
 
        iCalc = Application.Calculation
        Application.Calculation = xlCalculationManual
 
        For Each rRow In wks.UsedRange.Rows
            If WorksheetFunction.CountA(rRow.Cells) = 0 Then rRow.EntireRow.Delete
        Next rRow
    End With
 
    With Application
        .Calculation = iCalc
        .ScreenUpdating = bUpd
        .StatusBar = False
    End With
End Sub

 

[HWL]

Try setting calculation to manual and screenupdating to false before deleting the rows, and then restore them when you're done.

Thanks, I'm sorry but I already do that at the beginning of the macro:


Application.StatusBar = "****Please Wait***** Macro processing"
'Merge multiple workbooks into one
'Disable screen updating which will help decrease screen flickering while macro runs.
Application.ScreenUpdating = False
'opitmize macro by disabling all processes that slow it down.
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False

 

[HWL]

Sub x()
    Dim wks         As Worksheet
    Dim bUpd        As Boolean
    Dim iCalc       As XlCalculation
    Dim rRow        As Range
 
    Set wks = Worksheets(1)
 
    With wks
        Application.StatusBar = "****Please Wait***** Formatting " & wks.Name
        Application.Goto wks.Rows(2)
        ActiveWindow.FreezePanes = True
 
        With .Cells.Font
            .Name = "Arial"
            .Size = 12
        End With
 
        .Columns.AutoFit
        .Rows.AutoFit
 
        bUpd = Application.ScreenUpdating
        Application.ScreenUpdating = False
 
        iCalc = Application.Calculation
        Application.Calculation = xlCalculationManual
 
        For Each rRow In wks.UsedRange.Rows
            If WorksheetFunction.CountA(rRow.Cells) = 0 Then rRow.EntireRow.Delete
        Next rRow
    End With
 
    With Application
        .Calculation = iCalc
        .ScreenUpdating = bUpd
        .StatusBar = False
    End With
End Sub

Hmm, thanks for the work on this. This code doesn't seem to make it run any faster. It still bogs down at this point and takes almost 10 minutes to complete. Again, it is only about 3000 rows and about 35 columns. Any other idea?

 

[wigi]

Is the loop the part of the code that is taking a lot of time?
Are there any events used in the file?
Is the order of the rows important in worksheet 1? (if not, just sort the sheet and the rows will go to the end of the sheet, effectively "removing them")

 

[HWL]

Is the loop the part of the code that is taking a lot of time?
Are there any events used in the file?
Is the order of the rows important in worksheet 1? (if not, just sort the sheet and the rows will go to the end of the sheet, effectively "removing them")

The events are disabled at the start of the macro. The order isn't important but I already tested the "delete row" part by commenting it out and yet the macro is still slow so that must not be it. This is weird.

 

[wigi]

What part is slow, then?

Do you confine actions to the usedrange of a sheet, instead of *all* cells in the sheet? (just to be sure)

 

[HWL]

What part is slow, then?

Do you confine actions to the usedrange of a sheet, instead of *all* cells in the sheet? (just to be sure)

Well, the code I posted is just a snippet of the overall macro. It is just that snippet that is slow. I implemented shg code which seemed to have no effect. I suspect the code that is slowing it down is:

With .Cells.Font
.Name = "Arial"
.Size = 12
End With
.Columns.AutoFit
.Rows.AutoFit

To test, I commented this out and the macro was done within 30 seconds. So, yes it is this portion that needs help.

 

[wigi]

Investigate whether this:

With .Cells.Font

targets only the usedrange of the sheet, or the full sheet.

What is the usedrange of that sheet, by the way?