Макрос для удаления строк замерзает в половине случаев

Question

Есть ли более эффективный способ выполнить следующую операцию добавления трех значений ячеек в строку к соответствующим ячейкам выше, а затем удалить старую строку? Половина времени замораживания макроса; Я запускаю его примерно на 12 000 строк (на листе нет динамических формул).

Application.ScreenUpdating = False 

For a = Lcell To 2 Step -1 
    If Cells(a, 23).Value = Cells(a - 1, 23).Value Then 
     Cells(a, 16).Value = Cells(a, 16).Value + Cells(a - 1, 16).Value 
     Cells(a, 17).Value = Cells(a, 17).Value + Cells(a - 1, 17).Value 
     Cells(a, 18).Value = Cells(a, 18).Value + Cells(a - 1, 18).Value 
     Cells(a - 1, 1).EntireRow.Delete 
    End If 
Next a 

Application.ScreenUpdating = True 

Answer 1

на основе предположения Стива Мартина, попробуйте следующее:

For a = Lcell To 2 Step -1 
    If Cells(a, 23).Value = Cells(a - 1, 23).Value Then 
     Cells(a-1, 16).Value = Cells(a, 16).Value + Cells(a - 1, 16).Value 
     Cells(a-1, 17).Value = Cells(a, 17).Value + Cells(a - 1, 17).Value 
     Cells(a-1, 18).Value = Cells(a, 18).Value + Cells(a - 1, 18).Value 
     Cells(a, 1).EntireRow.Delete 
    End If 
Next a 

Answer 2

Один вариант, когда удаление ячеек является использование UNION-УДАЛИТЬ шаблон. Это сохраняет шаг удаления до тех пор, пока логика не будет определена и не сделает все сразу. Этот метод позволяет удалить диапазон, который выполняется итерацией. Это также уменьшает операции, которые должны улучшить скорость увеличения. Однако я не тестировал его на скорость.

Edited код, чтобы удалить последнюю строку на основе комментариев

Dim rng_delete As Range 

For A = Lcell To 2 Step -1 
    If Cells(A, 23).Value = Cells(A - 1, 23).Value Then 
     Cells(A - 1, 16).Value = Cells(A, 16).Value + Cells(A - 1, 16).Value 
     Cells(A - 1, 17).Value = Cells(A, 17).Value + Cells(A - 1, 17).Value 
     Cells(A - 1, 18).Value = Cells(A, 18).Value + Cells(A - 1, 18).Value 

     'rng_delete starts empty which errors Union on first add 
     If rng_delete Is Nothing Then 
      Set rng_delete = Cells(A, 1).EntireRow 
     Else 
      Set rng_delete = Union(rng_delete, Cells(A, 1).EntireRow) 
     End If 
    End If 
Next A 

rng_delete.Delete