Soru Dolu Satırlarda İşlem Yapmayı Hızlandırmak

[tuvons]

Arkadaşlar merhaba,

Aşağıda yazdığım kodlar ile filtrelenmiş veriler üzerinde değişiklik yapıyorum, fakat satır sayısı çok olunca ve filtrelediğim veriler örneğin 300.000'nci satırda olunca ilk dolu olan ilk satıra gelmesi çok uzun zaman alıyor. Hatta bazen excel hata veriyor.

Bu kodları nasıl değiştirebilirim dolu olan satırlara daha kısa sürede gelebilmesi için?

Not: Bu kodlarla D sütununda bulunan toplam verinin 1000'e bölünmesi ile E sütununda bulunan daha önceden 1000'e bölünmüş veriler aynı değilse ekleme veya çıkarma yaparak verileri eşitliyorum.

Sub eski()
With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
Application.ScreenUpdating = False
Range("D1").FormulaR1C1 = "=ROUND(SUBTOTAL(109,R[1]C:R[1048575]C)/1000,0)"
Range("E1").FormulaR1C1 = "=SUBTOTAL(109,R[1]C:R[1048575]C)"

If Range("D1").Value = Range("E1") Then Exit Sub

For i = 1 To 1000000
If Range("D1") > Range("E1") Then
Cells(i, 5).Select
ActiveCell.Offset(1, 0).Select
If ActiveCell.RowHeight < 1 Then GoTo basla2
ActiveCell.Value = ActiveCell.Value + 1
Else
GoTo bitir2
End If
basla2:
Next i
bitir2:
For j = 1 To 1000000
If Range("D1") < Range("E1") Then
Cells(j, 5).Select
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "0" Or ActiveCell.RowHeight < 1 Then GoTo basla
ActiveCell.Value = ActiveCell.Value - 1
Else
GoTo bitir
End If
basla:
Next j
bitir:
Range("D1") = "PARA"
Range("E1") = "PARA_BINTL"
With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
Application.ScreenUpdating = True
End Sub