Optimização de Código

[OutOfMemory]

Olá, desde já peço desculpa caso já exista um tópico semelhante, mas caso sim não o encontrei e estou a precisar de ajuda.

Apenas sou iniciado em VBA e ainda não sei muito, no entanto estou a afazer um código que vai verificar se em uma coluna "B" existe valores repetidos, caso sim nos valores iguais vai verificar na coluna "C" qual possui o maior valor, copiando o que tiver o menor para uma 2º tabela eliminando-o da 1º. O código já faz o pretendido no entanto preciso de corre-lo em tabelas com 60 mil linhas ou mais, e quando testo em tabelas com 5 mil linhas ou 10 mil linhas, o código dura entre 6 a 15 minutos a correr ( isto com sorte ). A minha questão é como posso optimizar o meu códiogo, se devo mudar o meu ciclo para um ciclo for each ou devo manter o Do While?

Aqui vai o código que fiz:

Function Copia()

Worksheets("Sheet1").Range("A1:AQ1").Copy _
Destination:=Worksheets("Sheet2").Range("A1")

Dim lRow As Long
Dim lRow2 As Long
Dim Row As Long
Dim contA As Long
Dim contB As Long
Dim t As Double

lRow = 5000
Row = 2
contA = 0
contB = 0

Application.ScreenUpdating = False
ViewMode = Activewindow.View
Activewindow.View = xlNormalView
Application.EnableEvents = False
Application.DisplayStatusBar = False

ActiveSheet.DisplayPageBreaks = False
lRow2 = lRow - 1
t = Timer

 Do While lRow > 2


		If (Cells.Item(lRow, "B") <> Cells.Item(lRow2, "B")) Then

			lRow = lRow - 1
			lRow2 = lRow - 1

		Else

			If (Cells.Item(lRow, "C") > Cells.Item(lRow2, "C")) Then

				Sheets("Sheet1").Rows(lRow2).Copy Sheets("Sheet2").Rows(Row)
				Rows(lRow2).Delete
				lRow = lRow - 1
				Row = Row + 1
				contA = contA + 1


			Else

				Sheets("Sheet1").Rows(lRow).Copy Sheets("Sheet2").Rows(Row)
				Rows(lRow).Delete
				lRow = lRow - 1
				Row = Row + 1
				contB = contB + 1

			End If

			lRow2 = lRow2 - 1

	   End If

Loop

Application.DisplayStatusBar = True
Activewindow.View = ViewMode
Application.ScreenUpdating = False
MsgBox "A = " & contA & " B = " & contB & "Duracao : " & (Timer - t) / 60

End Function

[OutOfMemory]

Eu já consegui este código que parece ser mais rápido, no entanto quando chega à parte do "rngDel.Delete" dá erro "Run-time error 1004 " "Application-defined or object-defined error".

Function Copia()
Debug.Print Timer
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim lRow As Long, Row As Long, viewmode
Dim countA As Long, countB As Long
Dim t As Double, rw As Range, rngDel As Range

lRow = 5000
Row = 2
countA = 0
countB = 0

Set shtSrc = Worksheets("Sheet1")
Set shtDest = Worksheets("Sheet2")

shtSrc.Range("A1:AQ1").Copy Destination:=shtDest.Range("A1")

Application.ScreenUpdating = False
viewmode = Activewindow.View
Activewindow.View = xlNormalView
Application.EnableEvents = False
Application.DisplayStatusBar = False

ActiveSheet.DisplayPageBreaks = False

t = Timer

 Do While lRow > 2

		Set rw = shtSrc.Rows(lRow)

		If (rw.Cells(2) = rw.Cells(2).Offset(-1, 0)) Then

			If (rw.Cells(3) > rw.Cells(3).Offset(-1, 0)) Then
				rw.Offset(-1, 0).Copy shtDest.Rows(Row)
				AddToRange rngDel, rw.Offset(-1, 0)
				countA = countA + 1
			Else
				rw.Copy shtDest.Rows(Row)
				AddToRange rngDel, rw
				countB = countB + 1
			End If

			Row = Row + 1


	 End If

	 lRow = lRow - 1

Loop


Debug.Print Timer
'anything to delete?
If Not rngDel Is Nothing Then
	rngDel.Delete
End If

Application.DisplayStatusBar = True
Activewindow.View = viewmode
Application.ScreenUpdating = False
Debug.Print Timer
Debug.Print "A = " & countA & " B = " & countB


End Function

'utility sub for building up a range
Sub AddToRange(rngTot, rng)
If rngTot Is Nothing Then
	Set rngTot = rng
Else
	Set rngTot = Application.Union(rng, rngTot)
End If
End Sub

Alguma sugestão de como corrigir o erro?

PS: Caso mude o .Delete para .Clear passa a dar, no entanto não com o resultado pretendido.