Skip to main content

AccessTr.neT


Mükerrer Kaydı Onayla Yaptırmak.

Mükerrer Kaydı Onayla Yaptırmak.

Çözüldü #1
Ü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.
.rar Deneme.rar (Dosya Boyutu: 1,05 MB | İndirme Sayısı: 2)
Son Düzenleme: 09/08/2021, 21:46, Düzenleyen: reosman.
Cevapla
#2
Merhaba.
Alttaki kodu deneyin.
Kodunuzda gereksiz olmuş dictionary.


Visual Basic Code
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:D" & 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
.rar Deneme.rar (Dosya Boyutu: 1,03 MB | İndirme Sayısı: 18)
Cevapla
#3
Çok teşekkür ederim hocam ilginize. Rabbim sizden razı ve memnun olsun. Sağolun varolun.
Cevapla
#4
Rica ederim,sizdende.
Cevapla
#5
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.
Cevapla
#6
Visual Basic Code
If son < 2 Then son = 2
yerine alttaki kodu deneyin.
Visual Basic Code
If son < 2 Then Exit Sub
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task