Excel VBA嵌套循環效率

Question

我希望提高此Excel VBA嵌套循環的速度。 循環比較一張紙和第二張紙上的日期。 如果它們匹配，我將更改單元格周圍的邊框以使其突出顯示。 目前，它可以正常工作，但每個子進程大約需要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 ？ 它禁用屏幕更新和我的宏走快了很多 。 您還可以禁用（然后重新啟用）其他設置，例如，請參見此網站 。

---

在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時cellA.value = cellB.value ，我救了cellA在另一個范圍（ RngToColor ）。 在代碼的末尾，我為該范圍內的所有邊框着色。 另外， Dim myColor As Variant和更高版本的myColor = Array("38")對我不起作用（ .ColorIndex = myColor在抱怨），因此我將其更改為Integer 。