Kod:
Sub izarsiv()
Dim s1 As Worksheet, s2 As Worksheet
Dim son As Long, Veri As Variant, X As Long
Dim say As Long, Tarih As Double
Tarih = Date
Set s1 = Sheets("İz")
Set s2 = Sheets("İz_Arşiv")
son = s1.Cells(s1.Rows.Count, 1).End(3).Row
If son < 2 Then son = 2
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:D" & Rows.Count), Veri(X, 4)) > 0 Then
If MsgBox(Veri(X, 4) & " Sicil Numarası Arşiv Kayıtlarında Var!!" & vbCr & vbCr & _
"Mükerrer Olarak Tekrar Aktarılsın mı ?", vbQuestion + vbYesNo, "Mükerrer Kayıt Onayı") = 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
End SubBu hatanın düzeltilmesi için ne yapmam gerekir bayağı uğraştım beceremedim. Yardımınızı rica ediyorum.
