Alttaki kodu deneyin.
Kodunuzda gereksiz olmuş dictionary.
Sub izarsiv()
Dim s1 As Worksheet, s2 As Worksheet, Dizi As Object
Dim son As Long, Veri As Variant, X As Long
Dim say As Long
Set s1 = Sheets("Ýz")
Set s2 = Sheets("Ýz_Arþiv")
son = s1.Cells(s1.Rows.Count, 1).End(3).Row
If son < 3 Then son = 3
Veri = s1.Range("A2:F" & son).Value
ReDim Liste(1 To UBound(Veri), 1 To 6)
For X = LBound(Veri, 1) To UBound(Veri, 1)
If WorksheetFunction.CountIf(s2.Range("D2
" & Rows.Count), Veri(X, 4)) > 0 Then
If MsgBox(Veri(X, 4) & " sicil nolu kayit bulundu.Aktarilsin mi?", vbQuestion + vbYesNo, "Mükerrer") = vbYes Then
say = say + 1
Liste(say, 1) = Veri(X, 1)
Liste(say, 2) = Veri(X, 2)
Liste(say, 3) = Veri(X, 3)
Liste(say, 4) = Veri(X, 4)
Liste(say, 5) = Veri(X, 5)
Liste(say, 6) = CDate(Tarih)
End If
Else
say = say + 1
Liste(say, 1) = Veri(X, 1)
Liste(say, 2) = Veri(X, 2)
Liste(say, 3) = Veri(X, 3)
Liste(say, 4) = Veri(X, 4)
Liste(say, 5) = Veri(X, 5)
Liste(say, 6) = CDate(Tarih)
End If
Next
If say > 0 Then
s2.Cells(s2.Rows.Count, 1).End(3)(2, 1).Resize(UBound(Liste, 1), UBound(Liste, 2)) = Liste
MsgBox "Veri Aktarýmý Tamamlanmýþtýr." & vbCr & vbCr & _
Chr(10) & say & " Adet Kayýt Baþarýyla Aktarýldý!", vbInformation, "Aktarým Bilgisi"
Else
MsgBox "Aktarýlacak Uygun Kayýt Bulunamadý!", 16, "Mükerrer & Kayýt Yok"
End If
Set s1 = Nothing
Set s2 = Nothing
Set Dizi = Nothing
End Sub
