Excel VBA hide 3000 rows optimizing

Question

My first question :)

Have a sheet with 3000 lines that needs to be checked and hided every time the sheet is activated.

Normally only 100 lines are to be visible but I had to make sure it always was enough lines. (Just in case).

I have this code that works well but are a little slow. Tips for speeding it up would be great.

Private Sub Worksheet_Activate()
On Error GoTo ExitHandling

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

        'Hide Operations columns if no values
        If Worksheets("BasicData").Range("CheckOperationsZero").Value = "Yes" Then
            Columns("I:J").EntireColumn.Hidden = True
        Else
            Columns("I:J").EntireColumn.Hidden = False
        End If

        'Hide empty rows, dont hide if row belowe is not empty, autofit for better viewing
        ActiveSheet.Rows("17:3017").EntireRow.Hidden = False
        For I = 3016 To 18 Step -1
            If Application.WorksheetFunction.CountIf(Range("B" & I & ":J" & I), vbNullString) >= 9 And Application.WorksheetFunction.CountIf(Range("B" & I + 1 & ":J" & I + 1), vbNullString) >= 9 Then
                Rows(I).RowHeight = 12
                Rows(I).EntireRow.Hidden = True
            Else
                Rows(I).EntireRow.AutoFit
                    If Rows(I).Height < 20 Then
                        Rows(I).RowHeight = 12
                    End If
            End If
        Next I

ExitHandling:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Exit Sub

ErrorHandling:
    MsgBox Err.Description
    Resume ExitHandling

End Sub

Answer 1

The following code uses 2 optimisations:
- calculate each row's state only once, not twice, by saving the previously computed value for the next iteration
- collect all empty rows in one range object and format this in one step. Format the rest of the range by addressing the "visible" cells (via SpecialCells).

Sub Worksheet_Activate()
    ' optimized for performance
    Const entireRange = "B17:J3017"

    Dim rowptr As Range
    Dim emptyrows As Range
    Dim I As Long
    Dim thisRowIsEmpty As Boolean, nextRowIsEmpty As Boolean

    On Error GoTo ExitHandling

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

    'Hide Operations columns if no values
    If Worksheets("BasicData").Range("CheckOperationsZero").Value = "Yes" Then
        Columns("I:J").EntireColumn.Hidden = True
    Else
        Columns("I:J").EntireColumn.Hidden = False
    End If

    'Hide empty rows, dont hide if row belowe is not empty, autofit for better viewing
    Rows("17:3017").EntireRow.Hidden = False
    Set emptyrows = Cells(5000, 1)
    Set rowptr = Range("B3017:J3017")
    nextRowIsEmpty = Application.WorksheetFunction.CountIf(rowptr, vbNullString) >= 9
    For I = 3016 To 18 Step -1
        Set rowptr = rowptr.Offset(-1, 0)
        thisRowIsEmpty = Application.WorksheetFunction.CountIf(rowptr, vbNullString) >= 9
        If thisRowIsEmpty And nextRowIsEmpty Then
            Set emptyrows = Application.Union(emptyrows, rowptr)
        End If
        nextRowIsEmpty = thisRowIsEmpty
    Next I

    If Not emptyrows Is Nothing Then
        With emptyrows
            .RowHeight = 12
            .EntireRow.Hidden = True
        End With
    End If
    With Range(entireRange).SpecialCells(xlCellTypeVisible).EntireRow
        .AutoFit
        If .Height < 20 Then
            .RowHeight = 12
        End If
    End With

ExitHandling:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Exit Sub

ErrorHandling:
    MsgBox Err.Description
    Resume ExitHandling
End Sub

On my notebook this code will run in 0.15 s instead of 2.0 s, so the speedup is roughly 10:1.

Answer 2

Here's an old post of mine. How to speed up multiple replacement using VBA in Word?

Remember MINIMISE DOTS.

Read the post as it lists 4 performance killers.

Minimise Dots

So if you are interested in performance minimise dots (each dot is a lookup), especially in loops.

There are two ways. One is to set objects to the lowest object if you are going to access more than once.

eg (slower)

set xlapp = CreateObject("Excel.Application")

msgbox xlapp.worksheets(0).name

(faster because you omitt a dot every time you use the object)

set xlapp = CreateObject("Excel.Application")

set wsheet = xlapp.worksheets(0)

msgbox wsheet.name

The second way is with. You can only have one with active at a time.

This skips 100 lookups.

with wsheet

For x = 1 to 100

    `msgbox .name`

Next

end with