Karşılaştırmalı Veri Çekme

[steppe]

Merhaba Arkadaşlar,
Aşağıdaki kodu uzun süredir kullanıyordum, hızı da fena değildi. Şimdilerde ise oldukça yavaş veri çekmeye başladı. Bu kodu daha hızlı nasıl çalıştırabiliriz.
Yardımlarınız için şimdiden teşekkür ederim.

Sub veri_cek()
Dim i As Long, sat1 As Long, sat2 As Long, k As Range
Application.ScreenUpdating = False
sat1 = Sayfa2.Cells(Rows.Count, "B").End(xlUp).Row
sat2 = Sayfa3.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To sat1
If Cells(i, "B").Value <> "" Then
Set k = Sayfa3.Range("A1:A" & sat2).Find(Cells(i, "B").Value, , xlValues, xlWhole)
If Not k Is Nothing Then
adr = k.Address
Do
If Cells(i, "D").Value = k.Offset(0, 2).Value And Cells(i, "E").Value = k.Offset(0, 3).Value Then
k.Offset(0, 1).Copy Sayfa2.Cells(i, "C")
k.Offset(0, 3).Copy Sayfa2.Cells(i, "E")
k.Offset(0, 4).Copy Sayfa2.Cells(i, "F")
Application.CutCopyMode = False
Exit Do
End If
Set k = Sayfa3.Range("A1:A" & sat2).FindNext(k)
Loop While Not k Is Nothing And k.Address <> adr
End If
End If
Next i
Sayfa2.Range("C2:F" & sat1).Font.Size = 10
Application.ScreenUpdating = True
End Sub