AccessTr.neT

Ü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" & 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

Çok teşekkür ederim hocam ilginize. Rabbim sizden razı ve memnun olsun. Sağolun varolun.

Rica ederim,sizdende.

Feraz hocam kod son şekliyle bu şekilde


İ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