Mükerrer TC

[Mikdad]

Selamun Aleykum doslarım, aşağıdaki kod ile ben c sutununa mükerrer tc girilmesini önlüyorum.
ama ihtiyacım olan şu ,
B Sutununda kayıt tarihi var. Girilen tc yi kontrol edecek ve B hücresine bakacak tarihi alacak
../..2020 tarihinde listeye eklenmiş tekrar eklemek istermesiniz diye soracak. evet dersek eklemeye müsade edecek.
şimdiden teşekkür ederim.

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, [C:C]) Is Nothing Then Exit Sub
    say = WorksheetFunction.CountIf(Range("C1:C" & Target.Row - 1), Target)
    If say > 0 Then
    MsgBox "BU KAYIT MEVCUTTUR"
    Target.Select
    Target = ""
    End If
    End Sub

 

[ÖmerFaruk]

Deneyin Lütfen.

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, [C:C]) Is Nothing Then Exit Sub

    Set TcNo = Range("C1:C" & Target.Row - 1).Find(Target.Value, LookIn:=xlValues)
    
    If Not TcNo Is Nothing Then
        MsgBox "Bu TC NO " & Range("B" & TcNo.Row) & " tarihinde girilmiş": Exit Sub
    End If
End Sub

 

[Mikdad]

hocam çok güzel sadece tamam yerine kaydı tekrar eklemek istermisiniz diye sorup eğer evet dersek ekleme yapacak hayır dersek eklemeyi engelleyecek şekilde yapabilir miyiz.

 

[çıtır]

Aşağıdaki şekilde deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, [C:C]) Is Nothing Then Exit Sub
    say = WorksheetFunction.CountIf(Range("C1:C" & Target.Row - 1), Target)
    If say > 0 Then
    son = Cells(100000, "B").End(3).Row
    Bldgr = Target.Value
    Set Hcr = Range("C1:C" & son)
    Set HcrBl = Hcr.Find(what:=Bldgr, LookAt:=xlWhole, MatchCase:=True)
    If Not HcrBl Is Nothing Then
       ms = ms & " " & Range("B" & HcrBl.Row)
    If MsgBox(ms & " TARİHİNDE VAR SİLİNSİN Mİ? ", vbYesNo + vbQuestion, "SORU", 500, 50) = vbNo Then Exit Sub
    Target.Select
    Target = ""
    End If
    End If
    End Sub

 

[Mikdad]

Hocam Harikasınız. Allah Razı Olsun

Aşağıdaki şekilde deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, [C:C]) Is Nothing Then Exit Sub
    say = WorksheetFunction.CountIf(Range("C1:C" & Target.Row - 1), Target)
    If say > 0 Then
    son = Cells(100000, "B").End(3).Row
    Bldgr = Target.Value
    Set Hcr = Range("C1:C" & son)
    Set HcrBl = Hcr.Find(what:=Bldgr, LookAt:=xlWhole, MatchCase:=True)
    If Not HcrBl Is Nothing Then
       ms = ms & " " & Range("B" & HcrBl.Row)
    If MsgBox(ms & " TARİHİNDE VAR SİLİNSİN Mİ? ", vbYesNo + vbQuestion, "SORU", 500, 50) = vbNo Then Exit Sub
    Target.Select
    Target = ""
    End If
    End If
    End Sub

 

[çıtır]

Hocam Harikasınız. Allah Razı Olsun

Allah(C.C.) Cümlemizden razı olsun.Dönüş yaptığınız için teşekkür ederim.