如何加快 VBA 中的 For Each 循環？

Question

我有一個 Worksheet_Change 宏，它根據用戶在具有數據驗證列表的單元格中所做的選擇來隱藏/取消隱藏行。

代碼需要一分鍾才能運行。 它在 c.2000 行上循環。 我希望它花費接近幾秒鍾的時間，以便它成為一個有用的用戶工具。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    'Exit the routine early if there is an error
    On Error GoTo EExit

    'Manage Events
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

    'Declare Variables
    Dim rng_DropDown As Range
    Dim rng_HideFormula As Range
    Dim rng_Item As Range

    'The reference the row hide macro will look for to know to hide the row
    Const str_HideRef As String = "Hide"

    'Define Variables
    'The range that contains the week selector drop down
    Set rng_DropDown = Range("rng_WeekSelector")
    'The column that contains the formula which indicates if a row should 
    'be hidden c.2000 rows
    Set rng_HideFormula = Range("rng_HideFormula")

    'Working Code
    'Exit sub early if the Month Selector was not changed
    If Not Target.Address = rng_DropDown.Address Then GoTo EExit

    'Otherwise unprotect the worksheet
    wks_DailyPlanning.Unprotect (str_Password)

    'For each cell in the hide formula column
    For Each rng_Item In rng_HideFormula

        With rng_Item
            'If the cell says "hide"
            If .Value2 = str_HideRef Then

                'Hide the row
                .EntireRow.Hidden = True

            Else
                'Otherwise show the row
                .EntireRow.Hidden = False

            End If
        End With
    'Cycle through each cell
    Next rng_Item

    EExit:
    'Reprotect the sheet if the sheet is unprotected
    If wks_DailyPlanning.ProtectContents = False Then wks_DailyPlanning.Protect (str_Password)


    'Clear Events
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True

End Sub

我查看了該網站上其他用戶提供的一些鏈接，我認為問題在於我必須單獨遍歷每一行。

是否有可能創建像我可以一次應用於整個范圍的 .visible 設置的數組？

Answer 1

我建議將您的數據范圍復制到基於內存的數組並檢查它，然后使用該數據來調整每一行的可見性。 它最大限度地減少了您與工作表Range object 的交互次數，這會占用大量時間並且對大范圍的性能造成很大影響。

Sub HideHiddenRows()
    Dim dataRange As Range
    Dim data As Variant
    Set dataRange = Sheet1.Range("A13:A2019")
    data = dataRange.Value

    Dim rowOffset As Long
    rowOffset = IIf(LBound(data, 1) = 0, 1, 0)

    ApplicationPerformance Flag:=False

    Dim i As Long
    For i = LBound(data, 1) To UBound(data, 1)
        If data(i, 1) = "Hide" Then
            dataRange.Rows(i + rowOffset).EntireRow.Hidden = True
        Else
            dataRange.Rows(i + rowOffset).EntireRow.Hidden = False
        End If
    Next i
    ApplicationPerformance Flag:=True
End Sub

Public Sub ApplicationPerformance(ByVal Flag As Boolean)
    Application.ScreenUpdating = Flag
    Application.DisplayAlerts = Flag
    Application.EnableEvents = Flag
End Sub

Answer 2

為了提高性能，您可以使用范圍地址填充字典，並立即隱藏或取消隱藏，而不是隱藏/取消隱藏每個特定行（但這只是理論上的，您應該自己測試），只是一個例子：

Sub HideHiddenRows()
    Dim cl As Range, x As Long
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")

    x = Cells(Rows.Count, "A").End(xlUp).Row
    For Each cl In Range("A1", Cells(x, "A"))
        If cl.Value = 0 Then dic.Add cl.Address(0, 0), Nothing
    Next cl

    Range(Join(dic.keys, ",")).EntireRow.Hidden = False

End Sub

演示：

Answer 3

另一種可能：

Dim mergedRng As Range

'.......

rng_HideFormula.EntireRow.Hidden = False
For Each rng_Item In rng_HideFormula
    If rng_Item.Value2 = str_HideRef Then
        If Not mergedRng Is Nothing Then
            Set mergedRng = Application.Union(mergedRng, rng_Item)
        Else
            Set mergedRng = rng_Item
        End If
    End If
Next rng_Item
If Not mergedRng Is Nothing Then mergedRng.EntireRow.Hidden = True
Set mergedRng = Nothing

'........