Excel VBA隐藏3000行优化

Question

我的第一个问题:)

有一个包含 3000 行的工作表，每次激活工作表时都需要检查和隐藏。

通常只有 100 行是可见的，但我必须确保它始终是足够的行。 （以防万一）。

我的代码运行良好，但速度有点慢。加快速度的提示会很棒。

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

以下代码使用 2 个优化：
- 通过保存先前计算的值用于下一次迭代，只计算每行的状态一次，而不是两次
- 收集一个范围对象中的所有空行并一步格式化。通过寻址“可见”单元格（通过 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

在我的笔记本上，这段代码将在 0.15 秒而不是 2.0 秒内运行，因此加速比大约为 10:1。

Answer 2

这是我的一个旧帖子。 How to speed up multiple replacement using VBA in Word?

记住尽量减少点。

阅读这篇文章，因为它列出了 4 个性能杀手。

尽量减少点

因此，如果您对性能感兴趣，请尽量减少点（每个点都是一个查找），尤其是在循环中。

有两种方法。一种是如果您要访问不止一次，则将对象设置为最低的对象。

例如（较慢）

set xlapp = CreateObject("Excel.Application")

msgbox xlapp.worksheets(0).name

（更快，因为每次使用对象时都会省略一个点）

set xlapp = CreateObject("Excel.Application")

set wsheet = xlapp.worksheets(0)

msgbox wsheet.name

第二种方式是with。您一次只能激活一个with。

这会跳过 100 次查找。

with wsheet

For x = 1 to 100

    `msgbox .name`

Next

end with