şarta göre 3 sutunda mükerrer kayıt girişi engelleme

[dragon44760]

açıklamalar ekteki dosyada mevcuttur. yardımlarınız için teşekkürler

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim SAY As Long
    Dim BUL As Range
    Dim ADRES As String
    Dim SATIR As String
    Dim ONAY As Variant
    If Intersect(Target, [A2:C65536]) Is Nothing Then Exit Sub
    If Cells(Target.Row, "A") <> "" And Cells(Target.Row, "B") <> "" And Cells(Target.Row, "C") <> "" Then
    If Target.Count = 1 Then
    SAY = WorksheetFunction.CountIf(Columns(Target.Column), Target)
    Else
    SAY = WorksheetFunction.CountIf(Columns(Target.Column), Cells(Target.Row, 1))
    End If
    If SAY > 1 Then
    Set BUL = Range(Cells(2, Target.Column), Cells(Target.Row - 1, Target.Column)).Find(Target)
    If Not BUL Is Nothing Then
    ADRES = BUL.Address
    Do
    If Cells(Target.Row, "A") = Cells(BUL.Row, "A") And Cells(Target.Row, "B") = Cells(BUL.Row, "B") And Cells(Target.Row, "C") = Cells(BUL.Row, "C") Then
    SATIR = IIf(SATIR = "", BUL.Row & Space(1), SATIR & ", " & BUL.Row & Space(1))
    End If
    Set BUL = Range(Cells(2, Target.Column), Cells(Target.Row - 1, Target.Column)).FindNext(BUL)
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    GoTo UYARI
    End If: End If: End If
    GoTo SON
UYARI:
    If SATIR = "" Then GoTo SON
    ONAY = MsgBox("Bu kayıt daha önce aşağıdaki satırlarda girilmiştir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & Chr(10) & "İşleme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "DİKKAT !")
    If ONAY = vbNo Then
    Cells(Target.Row, "A") = ""
    Cells(Target.Row, "B") = ""
    Cells(Target.Row, "C") = ""
    Cells(Target.Row, 1).Select
    Exit Sub: End If
    Cells(Target.Row + 1, 1).Select
SON:
End Sub

 

[dragon44760]

Teşekkürler

hocam çok teşekkür ederim. ama başka bir sorun çıktı kopyala yapıştır yapınca aynı kayıtları kaydedebiliyorum. ne yapmam lazım_? yardımcı olursanız sevinirim. acaba o 3 sutunda kopya, kes - yapıştırı engelleyebilir miyiz_?

 

[dragon44760]

Yardımcı olursanız sevinirim.

sayın forum üyeleri yardımlarınızı bekliyorum

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.