İki sütuna göre veri çekme

[steppe]

Merhaba Arkadaşlar,

Sub veri_cek()
Set s1 = Sheets("Sayfa2")
Set s2 = Sheets("Sayfa4")
For a = 1 To s1.Range("e65500").End(3).Row
For b = 1 To s2.Range("d65500").End(3).Row
If s1.Cells(a, "e") = s2.Cells(b, "d") Then
s1.Cells(a, "b") = s2.Cells(b, "A")
s1.Cells(a, "c") = s2.Cells(b, "b")
s1.Cells(a, "d") = s2.Cells(b, "c")
s1.Cells(a, "f") = s2.Cells(b, "e")
End If
Next
Next
End Sub

Yukarıdaki kod ile Sayfa2'deki E sütunu ile Safa4'teki D sütununu karşılaştırıyorum. Eğer veriler eşleşiyorsa buna göre diğer sütunlardaki verileri Sayfa4'ten Sayfa2'ye çekebiliyorum. Yalnız kod çok yavaş çalışıyor. Kodun daha hızlı çalışması mümkün mü?
Yardımlarınız için şimdiden teşekkür ederim.

 

[Ziynettin]

Merhaba.

Sub veri_cek()
Z = TimeValue(Now)
Dim a(), b(), c()
Set s1 = Sheets("Sayfa2")
Set s2 = Sheets("Sayfa4")
son1 = s1.Cells(Rows.Count, 5).End(3).Row
son2 = s2.Cells(Rows.Count, 4).End(3).Row
a = s2.Range("A1:E" & son2).Value
b = s1.Range("E1:E" & son1).Value
Set dc = CreateObject("scripting.dictionary")
    For i = 1 To UBound(a)
        dc(a(i, 4)) = i
    Next i
ReDim c(1 To UBound(b), 1 To 5)
    For i = 1 To UBound(b)
        If dc.exists(b(i, 1)) Then
            s = dc(b(i, 1))
            c(i, 1) = a(s, 1)
            c(i, 2) = a(s, 2)
            c(i, 3) = a(s, 3)
            c(i, 4) = b(i, 1)
            c(i, 5) = a(s, 5)
        End If
    Next i
s1.[B1].Resize(UBound(b), 5) = c
MsgBox "İşlem bitti..." & vbLf & vbLf & _
    CDate(TimeValue(Now) - Z), vbInformation
End Sub

 

[steppe]

Ziynettin Hocam,
Çok teşekkür ederim. Oldukça hızlı çalışıyor.