Çözüldü Mükerrer kayıt Engelleme

[Asri]

Sayın Asri teşekkür ederim yardımlarınıza ilginize biraz fazla oldun diyeceksin bana ama birde mükerrer girilen kaydı msgboxla bildirirse çok güzel olacak.

Bildirmesi zaman kaybı gibi geliyor ama eklendi.

 

[okan32]

Elinize emeğimize sağlık sayın asri teşekkürler

 

[emograf]

Benim sorunum da şöyle ki;

"Kayıt Sayfası"ndan "Veri Tabanı" sayfasına makro ile veriler gelmektedir."B" sütununa gelen verilerin mükerrer olmasını engellemek istiyorum.
Yani, Aynı yıl içerisinde, aynı TC Kimlik Numarası ile kayıt yapılmasını engellemek istiyorum.

Kod sayfasında da yapmaya çalıştım ama yapamadım.

Yardımcı olursanız çok sevinirim.

Örnek çalışmam ektedir.
Mükerrer Kayıt Engelleme

 

[Erhan Köseoğlu]

.

 

[Asri]

Bir arkadaş, kodlar için açıklama istemiş.

Private Sub Worksheet_Change(ByVal Target As Range)
'Bir den fazla hücre seçilmiş ise kontrol yapma
   If Selection.Count > 1 Then Exit Sub
   'A ve B kolonlarında bir değişiklik olduğunda kontrol et
   If Intersect(Target, Range("A:B")) Is Nothing Then Exit Sub
   'değişiklik yapılan hücrenin satır ve sütun bilgisini al
   satir = Target.Row
   sutun = Target.Column
 
 'A ve B sutunlarında kullanılan son satır tespit ediliyor.
   sonsatira = Cells(Rows.Count, "A").End(3).Row
   sonsatirb = Cells(Rows.Count, "B").End(3).Row
 'Hangi kolonun son satırı daha büyük ise o sonsatır olaraka alınıyor
 If sonsatira > sonsatirb Then sonsatir = sonsatira Else sonsatir = sonsatirb
   say = 0
   'Değiştirilen hücredeki veri A ve B hücrelerinde satır satır karşılaştırılıyor'
   For i = 1 To sonsatir
   'A ve B hücresindeki veriler tüm satırlar boyunca birer defa alınıyor.
     veria = Cells(i, "A").Value
     verib = Cells(i, "B").Value
     'Her bir satırda alınan A ve B hücrelerindeki veriler değiştirilen hücredeki veri ile karşılaştırılıyor
     'Cells(satir, "A").Value  bilgisi değiştirilen hücredeki veri oluyor.
     'Say=say+1 ile verinin bulunma sayısı arttırılıyor
     If veria = Cells(satir, "A").Value And verib = Cells(satir, "B").Value Then say = say + 1
  
   Next i
   'Değiştirilen veri 1 den fazla bulunmuş ise mükerrer kayıt vardır.
   If say > 1 Then
    MsgBox (veria & " ve " & verib & " Mükerrer girildi.")
    
    'Change gibi event - olay makrolarında aynı alandaki hücreler değiştirildiğinde o bölüm döngüye girer ve hata alınır.
    'Bu yüzden events false yapılarak, yapılacak değişiklikte events ın devreye girmesi engellenir.
    Application.EnableEvents = False
     Cells(satir, "A").Value = ""
     Cells(satir, "B").Value = ""
    'Events tekrar aktif edilir. Aktif edilmez ise program yapılan değişiklikleri tespit edemeyecek.
    Application.EnableEvents = True

   End If
  
End Sub

 

[okan32]

Bir arkadaş, kodlar için açıklama istemiş.

Private Sub Worksheet_Change(ByVal Target As Range)
'Bir den fazla hücre seçilmiş ise kontrol yapma
   If Selection.Count > 1 Then Exit Sub
   'A ve B kolonlarında bir değişiklik olduğunda kontrol et
   If Intersect(Target, Range("A:B")) Is Nothing Then Exit Sub
   'değişiklik yapılan hücrenin satır ve sütun bilgisini al
   satir = Target.Row
   sutun = Target.Column

'A ve B sutunlarında kullanılan son satır tespit ediliyor.
   sonsatira = Cells(Rows.Count, "A").End(3).Row
   sonsatirb = Cells(Rows.Count, "B").End(3).Row
'Hangi kolonun son satırı daha büyük ise o sonsatır olaraka alınıyor
If sonsatira > sonsatirb Then sonsatir = sonsatira Else sonsatir = sonsatirb
   say = 0
   'Değiştirilen hücredeki veri A ve B hücrelerinde satır satır karşılaştırılıyor'
   For i = 1 To sonsatir
   'A ve B hücresindeki veriler tüm satırlar boyunca birer defa alınıyor.
     veria = Cells(i, "A").Value
     verib = Cells(i, "B").Value
     'Her bir satırda alınan A ve B hücrelerindeki veriler değiştirilen hücredeki veri ile karşılaştırılıyor
     'Cells(satir, "A").Value  bilgisi değiştirilen hücredeki veri oluyor.
     'Say=say+1 ile verinin bulunma sayısı arttırılıyor
     If veria = Cells(satir, "A").Value And verib = Cells(satir, "B").Value Then say = say + 1
 
   Next i
   'Değiştirilen veri 1 den fazla bulunmuş ise mükerrer kayıt vardır.
   If say > 1 Then
    MsgBox (veria & " ve " & verib & " Mükerrer girildi.")
   
    'Change gibi event - olay makrolarında aynı alandaki hücreler değiştirildiğinde o bölüm döngüye girer ve hata alınır.
    'Bu yüzden events false yapılarak, yapılacak değişiklikte events ın devreye girmesi engellenir.
    Application.EnableEvents = False
     Cells(satir, "A").Value = ""
     Cells(satir, "B").Value = ""
    'Events tekrar aktif edilir. Aktif edilmez ise program yapılan değişiklikleri tespit edemeyecek.
    Application.EnableEvents = True

   End If
 
End Sub

Sayın asri açıklamalarınız için teşekkür ederim bu kodu a b c sütunlarına aynı veri girilirse mükerrer kayıt uyarısını vermesi için nasıl düzenlenenebilir.

 

[Asri]

Sayın asri açıklamalarınız için teşekkür ederim bu kodu a b c sütunlarına aynı veri girilirse mükerrer kayıt uyarısını vermesi için nasıl düzenlenenebilir.

A,B,C kolonları için mükerrer kontrolü.

Private Sub Worksheet_Change(ByVal Target As Range)
   If Selection.Count > 1 Then Exit Sub
   If Intersect(Target, Range("A:C")) Is Nothing Then Exit Sub
   satir = Target.Row
   sutun = Target.Column
 
   sonsatira = Cells(Rows.Count, "A").End(3).Row
   sonsatirb = Cells(Rows.Count, "B").End(3).Row
   sonsatirc = Cells(Rows.Count, "C").End(3).Row
   If sonsatira > sonsatirb Then sonsatir = sonsatira Else sonsatir = sonsatirb
   say = 0
   For i = 1 To sonsatir
     veria = Cells(i, "A").Value
     verib = Cells(i, "B").Value
     veric = Cells(i, "C").Value
     If veria = Cells(satir, "A").Value And verib = Cells(satir, "B").Value And veric = Cells(satir, "C").Value Then say = say + 1
   Next i
   If say > 1 Then
    MsgBox (veria & " , " & verib & " ve " & veric & " Mükerrer girildi.")
    
    Application.EnableEvents = False
     Cells(satir, "A").Value = ""
     Cells(satir, "B").Value = ""
     Cells(satir, "C").Value = ""
    Application.EnableEvents = True

   End If
  
End Sub

 

[okan32]

A,B,C kolonları için mükerrer kontrolü.

Private Sub Worksheet_Change(ByVal Target As Range)
   If Selection.Count > 1 Then Exit Sub
   If Intersect(Target, Range("A:C")) Is Nothing Then Exit Sub
   satir = Target.Row
   sutun = Target.Column

   sonsatira = Cells(Rows.Count, "A").End(3).Row
   sonsatirb = Cells(Rows.Count, "B").End(3).Row
   sonsatirc = Cells(Rows.Count, "C").End(3).Row
   If sonsatira > sonsatirb Then sonsatir = sonsatira Else sonsatir = sonsatirb
   say = 0
   For i = 1 To sonsatir
     veria = Cells(i, "A").Value
     verib = Cells(i, "B").Value
     veric = Cells(i, "C").Value
     If veria = Cells(satir, "A").Value And verib = Cells(satir, "B").Value And veric = Cells(satir, "C").Value Then say = say + 1
   Next i
   If say > 1 Then
    MsgBox (veria & " , " & verib & " ve " & veric & " Mükerrer girildi.")
   
    Application.EnableEvents = False
     Cells(satir, "A").Value = ""
     Cells(satir, "B").Value = ""
     Cells(satir, "C").Value = ""
    Application.EnableEvents = True

   End If
 
End Sub

Harikasınız sayın asri çok teşekkürler

 

[Korhan Ayhan]

Alternatif,

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A:C")) Is Nothing Then Exit Sub
    Say = WorksheetFunction.CountIfs(Columns(1), Cells(Target.Row, "A"), Columns(2), Cells(Target.Row, "B"), Columns(3), Cells(Target.Row, "C"))
    If Say > 1 Then
        MsgBox "Mükerrer kayıt!" & vbCrLf & vbCrLf & Cells(Target.Row, "A") & " " & Cells(Target.Row, "B") & " " & Cells(Target.Row, "C")
        Cells(Target.Row, "A").Resize(, 3).ClearContents
    End If
End Sub