Excel VBA 嵌套循环效率

Question

我希望提高这个 Excel VBA 嵌套循环的速度。该循环将日期从一张纸与第二张纸进行比较。如果它们匹配，我会更改单元格周围的边框以突出显示它。它目前工作正常，但每个 sub 大约需要 30 秒来处理。有没有办法实现一个数组或其他策略来加速它？提前致谢！

Sub Single()

Dim DateRng As Range, DateCell As Range, DateRngPay As Range
Dim cellA As Range
Dim cellB As Range
Dim myColor As Variant

Set DateRng = ActiveWorkbook.Worksheets("SS").Range("B11:F16,I11:M16,P11:t16,B19:F24,I19:M24,P19:t24,B27:F32,I27:M32,P27:t32,B35:F40,I35:M40,P35:t40")
Set DateRngPay = ActiveWorkbook.Worksheets("PS").Range("C2:C67")
myColor = Array("38")

If ActiveWorkbook.Worksheets("Info").Range("B67") = 1 Then
    With DateRng
            .Interior.ColorIndex = xlColorIndexNone
            '.Borders.LineStyle = xlContinuous
            .Borders.ColorIndex = 1
            .Borders.Weight = xlHairline
    For Each cellA In DateRng
        For Each cellB In DateRngPay
                If cellB.Value > "" And cellA.Value > "" And cellB.Value = cellA.Value Then
                With cellA.Borders
                    .ColorIndex = myColor
                    .Weight = xlMedium
                End With
                Exit For
            End If
        Next cellB
    Next cellA
    End With
End If
End Sub

Answer 1

您是否尝试过在代码顶部使用Application.ScreenUpdating = False，然后在底部使用Application.ScreenUpdating = True？它会禁用屏幕更新，并且我的宏会快很多。您还可以禁用（然后重新启用）其他设置，例如参见this website。

---

在 OP 评论后更新 Application.ScreenUpdating = False 没有提高速度：

我稍微更改了您的代码，并看到了一些速度改进。你的代码通常需要大约 0.65 秒才能完成，我的大约需要 0.51 秒。这段代码会为您加快速度吗？

Sub SingleIsAnIdentifier_SoItCannotBeUsedAsASubName()

Dim DateRng As Range, DateCell As Range, DateRngPay As Range
Dim cellA As Range
Dim cellB As Range
Dim myColor As Integer

Dim RngToColor As Range 'Range to hold all cells to give a colored border.

Set DateRng = ActiveWorkbook.Worksheets("SS").Range("B11:F16,I11:M16,P11:t16,B19:F24,I19:M24,P19:t24,B27:F32,I27:M32,P27:t32,B35:F40,I35:M40,P35:t40")
Set DateRngPay = ActiveWorkbook.Worksheets("PS").Range("C2:C67")
myColor = 38

If ActiveWorkbook.Worksheets("Info").Range("B67") = 1 Then
    With DateRng
            .Interior.ColorIndex = xlColorIndexNone
            '.Borders.LineStyle = xlContinuous
            .Borders.ColorIndex = 1
            .Borders.Weight = xlHairline
    End With
    For Each cellA In DateRng
        For Each cellB In DateRngPay
            If cellB.Value > "" And cellA.Value > "" And cellB.Value = cellA.Value Then

                ' Add cellA to the range. The range will be colored later.
                If Not RngToColor Is Nothing Then
                    Set RngToColor = Union(RngToColor, cellA)
                Else
                    Set RngToColor = cellA
                End If

            End If
        Next cellB
    Next cellA
End If

' Color all cells in the range.
With RngToColor.Cells.Borders
    .ColorIndex = myColor
    .Weight = xlMedium
End With

End Sub

我没有在cellA.value = cellB.value 时立即为cellA 的边框着色，而是将cellA 保存在另一个范围（RngToColor）中。在代码的末尾，我为该范围内的所有边框着色。此外，Dim myColor As Variant 和后来的myColor = Array("38") 对我不起作用（.ColorIndex = myColor 正在抱怨），所以我将其更改为 Integer。