Eliminar gran cantidad de filas

Tengo una macro para copiar registros de una base de datos a una nueva hoja Excel y posteriormente eliminarlos de la BD en función de unos criterios.

Para ello lo que he hecho es filtrar por esos criterios, copiar los datos y luego eliminar las filas. Toda la macro transcurre perfectamente hasta que se "cuelga" cuando ha de eliminar muchos de los registros.

Adjunto el código a ver si algún alma caritativa me puede ayudar.

Sub Quita2()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False
Dim contarsi As Double
Dim criterio As String
For i = 2 To 20
contarsi = Application.WorksheetFunction.CountIf(Sheets("Registro").Columns(12), Sheets("Criterios").Cells(i, 2))
If contarsi >= 1 Then
Sheets("Registro").Range("$A$2:$AO$20142").AutoFilter Field:=12, Criteria1:=Sheets("Criterios").Cells(i, 2).Value, Operator:=xlFilterValues
Range("A2:AO" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Quitadas").Range("A20142").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
Sheets("Registro").Select
Application.CutCopyMode = False
Selection.ClearContents
Selection.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
Next i
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.CutCopyMode = False
Application.DisplayAlerts = True

Se ha puesto el condicional if para "contarsi" porque no siempre están los registros con dichos criterios.