Mükerrer veriye Onay vermeli Kod

[Yesilyurtlu]

Hayırlı Akşamlar

Değerli Uzmanlarım Excelde b sütununun 9. hücresinden itibaren veri girişi yapılıyor. Eğer Mükerrer kayıt girişi yapmış isem şu hücrede bu isimli öğretmen girilmiştir. Kayıtın mükerrer yapılmasını onaylıyor mısınız?
Evet ise İsmi yazacak Hayır ise Mükerrer Kayıt İptal edildi

Böyle bir kodda yardımınızı istiyorum

 

[uzmanamele]

merhaba
bunun için kod yazılabilir ama ek dosya da işinizi görebilir, deneyiniz.
beğenmezseniz makro çözüm ararız.

 

[Yesilyurtlu]

Uzmanım Bu örnekte zannedersem açılır kutu listeyi sarı yerden alıyor.

Benim isteğim de rastgele isimler girileceğinden makro kod daha güzel olacak görüşündeyim.

Karar Uzmanımındır

 

[uzmanamele]

Uzmanım Bu örnekte zannedersem açılır kutu listeyi sarı yerden alıyor.

Benim isteğim de rastgele isimler girileceğinden makro kod daha güzel olacak görüşündeyim.

Karar Uzmanımındır

merhaba
rastgele isim gireceksiniz ama girdiğiniz isimler öğretmen isimleri olacak, müstahdem ismi girmeyeceğinize göre öğretmelerin adını listeleyip kullanmanızda mahsur olmamalı.

 

[Yesilyurtlu]

Tamam Uzmanım.
Çift iş olacak ama olsun. İlönce öğretmen isimlerini bir sütuna kayıt edeceğiz sonra da oradan alacağız.
Allah Razı olsun Teşekkür Ederim Uzmanım

 

[uzmanamele]

merhaba

bu kod işinizi görür mü?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim onay As Byte
    If Intersect(Target, Range("b9:b65536")) Is Nothing Then Exit Sub
    If Target.Count <> 1 Then Exit Sub
For i = 9 To Cells(65536, 2).End(xlUp).Row
        If Target.Address <> Cells(i, 2).Address Then
            If Target = "" Then GoTo son
                If Cells(i, 2) = Target Then
            onay = MsgBox(Target.Text & vbCrLf & "Bu İsim Daha Önceden Girilmiş!!!" & vbCrLf & "Devam Etmek İçin Onaylayınız.", vbInformation + vbYesNo, "HOP DEDİK!!!")
            If onay = vbYes Then GoTo son
            If onay = vbNo Then Target = Empty
            End If
        End If
Next i
son:
End Sub

 

[tahsinanarat]

Sn. Yesilyurtlu aşağıdaki kodlar işinizi görür (kodları evvelce bu siteden temin etmiştim. Kim yazdıysa eline sağlık)

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [B9:B500]) Is Nothing Then Exit Sub
SAY = WorksheetFunction.CountIf([B9:B65536], Target)
If SAY > 1 Then
For Each ALAN In Range("B9:B" & [B65536].End(3).Row)
If ALAN = Target Then
If ADRES = "" Then
ADRES = ALAN.Address(False, False)
Else: ADRES = ADRES & " - " & ALAN.Address(False, False)
End If: End If: Next
ONAY = MsgBox("Bu Kayıt Daha Önceden Aşağıdaki Hücrelerde Girilmiştir !" & Chr(10) & Chr(10) & ADRES & Chr(10) & Chr(10) & "İşleme Devam Etmek İstiyor musunuz?", vbYesNo + vbCritical, "DİKKAT !")
If ONAY = vbNo Then
Target = ""
Target.Select
Exit Sub: End If
Target.Offset(1, 0).Select
End If:
End Sub

 

[Yesilyurtlu]

Uzmanamele UZMANIMA ve Tahsin ANARAT ağabeyime yardımları için teşekkür ederim

ikiside fevkalede işimi gördü. "Teşekkürümü geç yazdığım için affınıza sığınıyorum"