Üstadlarım,
"İz" sayfasındaki verileri "İz_Arşiv" sayfasına aktarırken mükerrer kayıt varsa aktarmasın şeklinde kullanıyorum.
Şu şekilde bir talebim olacak,
Eğer sicil numarasına göre mükerrer kayıt olursa,
D sütununa göre mükerrer kaydı bulsun, D sütunu içeriğini (Sicil Numarasını) yazsın
ve onay istesin. Her mükerrer kayıt için EVET dersem aktarsın, HAYIR dersem aktarmasın.
Yardımlarınızı rica ediyorum. Saygılarımla.
Merhaba.
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
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
Çok teşekkür ederim hocam ilginize. Rabbim sizden razı ve memnun olsun. Sağolun varolun.
Feraz hocam kod son şekliyle bu şekilde
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 Sub
İz sayfasında herhangibir veri yokken 1 adet veri aktarıldı diyor ve İz_Arşiv sayfasına sadece tarih atıyor.
Bu hatanın düzeltilmesi için ne yapmam gerekir bayağı uğraştım beceremedim. Yardımınızı rica ediyorum.
If son < 2 Then son = 2
yerine alttaki kodu deneyin.
If son < 2 Then Exit Sub