Макрос для переноса строк на другой лист

[ren23rus]

Доброго времени суток. Помогите пожалуйста доработать макрос. Необходимо что бы строки с одного листа по определенному условию переносились на другой лист. При этом строки на первом листе полностью удалялись со сдвигом всех строк. Макрос написан, но работает очень медленно. На 5-ти строках и без присутствия других макросов все работает. Как только пишу этот код в файл с большим количеством строк и большим количеством макросов, то сразу начинает тормозить.

Sub Test1()
Dim iCell As Range, Priznak As Variant
    Priznak = ("a")
    For Each iCell In Range("G2", [G2].End(xlDown))
        If iCell = Priznak Then
            With Sheets("Лист2")
                iCell.EntireRow.Cut Destination:=.Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
                Selection.SpecialCells(xlCellTypeBlanks).Select
                Selection.Delete Shift:=xlUp
            End With
        End If
    Next iCell
 
End Sub

[EducatedFool]

Надо удалять все строки (ячейки) сразу, - тогда не будет тормозить.
Если же в цикле перебирать ячейки, и удалять по одной, - тормоза гарантированы.

Идеи можете почерпнуть в этом макросе:
http://excelvba.ru/code/ConditionalRowsDeleting

[ren23rus]

Спасибо большое за ответ.