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 на дне? Он отключает обновление экрана, а мои макросы идут много быстрее. Существуют и другие настройки, которые вы можете отключить (а затем снова включить), см., Например, this website.

---

Update после комментария ОП, что 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.