Mükerrer Kayıtları Engellemek

[Spatz]

Merhabalar,

Forumda mükerrer kayıtları engellemek için örnekler mevcut. Lakin bir kaç modifikasyona ihtiyaç duyduğumdan işin içinden çıkamadım. Örneğin şöyle bir kod buldum:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For a = [a65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, "a")) > 1 Then Rows(a).Delete
Next
End Sub

Ama ben mükerrer kayıt için onay sorsun istiyorum. Onaylarsam izin versin, şunu ekledim ama ne yazık ki her seferinde baştan arama yaptığı için uyarı sürekli çıkıyor. Bunu nasıl engelleriz.

Teşekkürler.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For g = [g65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("g1:g" & g), Cells(g, "g")) > 1 Then
Onay = MsgBox("Sistemde bu giriş kayıtlı. Yine de eklemek istiyor musunuz?", vbInformation + vbYesNo, "UYARI!")
        If Onay = vbYes Then MsgBox "Eklendi", vbInformation, "Bilgi"
        If Onay = vbNo Then Rows(g).Delete
End If
Next
End Sub

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim son As Long, onay As String
    
    If Intersect(Target, Range("G:G")) Is Nothing Then Exit Sub
 
    son = Cells(Rows.Count, "G").End(xlUp).Row
    If WorksheetFunction.CountIf(Range("G1:G" & son), Target) > 1 Then
        onay = MsgBox("Sistemde bu giriş kayıtlı. Yine de eklemek istiyor musunuz?", vbInformation + vbYesNo, "UYARI!")
        If onay = vbYes Then MsgBox "Eklendi", vbInformation, "Bilgi"
        If onay = vbNo Then Target.ClearContents
    End If
 
End Sub

.