How can I speed up this For Each loop in VBA?

问题

I have an Worksheet_Change macro that hides/unhides rows depending on the choice a user makes in a cell with a data validation list.

The code takes a minute to run. It's looping over c.2000 rows. I'd like it to take closer to a few seconds so it becomes a useful user tool.

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

I have looked at some links provided by other users on this website and I think the trouble lies in the fact I'm having to iterate through each row individually.

Is it possible to create something like an array of .visible settings I can apply to the entire range at once?

回答1:

Another possibility:

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

'........

回答2:

I'd suggest copying your data range to a memory-based array and checking that, then using that data to adjust the visibility of each row. It minimizes the number of interactions you have with the worksheet Range object, which takes up lots of time and is a big performance hit for large ranges.

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

回答3:

to increase perfomance you can populate dictionary with range addresses, and hide or unhide at once, instead of hide/unhide each particular row (but this is just in theory, you should test it by yourself), just an example:

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

demo:

来源：https://stackoverflow.com/questions/58304413/how-can-i-speed-up-this-for-each-loop-in-vba