• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Mükerrer T.C Kimlik girişi.

S

sedat2161

Katılım
1 Ekim 2017
Mesajlar
694
Excel Vers. ve Dili
2019 türkçe
Hayırlı günler arkadaşlar. Ekli dosyamda B sütununa girdiğim T.C Kimlik Numaralarını 11 rakam ve mükerrer ise uyarmasını bir türlü yapamadımç Yardımcı olursanız çok memnun olurum.
 

Ekli dosyalar

Sayfa1 kod alanına bu kodu yapıştırın

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For i = 2 To 5000
If WorksheetFunction.CountIf(Range("b2:b" & i), Range("b" & i).Value) > 1 Then
MsgBox "MÜKERRER KAYIT", vbInformation
Range("b" & i).Value = Empty
End If
Next i
End Sub

Buradaki 5000 satırı öylesine yazdım , siz bir milyon da yazabilirsiniz. B sütununda mükerrer görünce uyarır, tamam deyince siler

Download file

www.filebig.net www.filebig.net
 

Ekli dosyalar

cems' Alıntı:
Sayfa1 kod alanına bu kodu yapıştırın

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For i = 2 To 5000
If WorksheetFunction.CountIf(Range("b2:b" & i), Range("b" & i).Value) > 1 Then
MsgBox "MÜKERRER KAYIT", vbInformation
Range("b" & i).Value = Empty
End If
Next i
End Sub

Buradaki 5000 satırı öylesine yazdım , siz bir milyon da yazabilirsiniz. B sütununda mükerrer görünce uyarır, tamam deyince siler

Download file

www.filebig.net www.filebig.net
Genişletmek için tıkla ...
Hocam çok sağ olun . Bildiğiniz gibi T.C Kimlik numaraları 11 rakamdan oluşuyor eksik veya fazla girdiğimizde de uyarı verirse çok iyi olur.
 
Alternatif olsun.
modül kısmına şu fonksiyonu ekleyiniz:
Function TCKMN(X As String) As String
Dim buff() As String
'Dim tekToplam, ciftToplam, uzunluk, toplamlar, onuncuRakam, onbirinciRakam, i As Integer
Dim tekToplam, ciftToplam, uzunluk, toplamlar, onuncuRakam, onbirinciRakam, i As Integer
buff = Split(StrConv(X, vbUnicode), Chr$(0))
ReDim Preserve buff(UBound(buff) - 1)
uzunluk = CInt(Application.CountA(buff))
If Len(X) <> 11 Then
TCKMN = "Hatalý TCKMN (11/" & uzunluk & ")!"
ElseIf CInt(buff(uzunluk - 1)) Mod 2 <> 0 Then
TCKMN = "Hatalý TCKMN (11.2)!"
ElseIf CInt(buff(0)) = 0 Then
TCKMN = "Hatalý TCKMN (0)!"
Else
For i = 0 To uzunluk - 1
If i Mod 2 <> 0 And i > 0 And i < 9 Then
ciftToplam = ciftToplam + CInt(buff(i))
ElseIf i < 9 Then
tekToplam = tekToplam + CInt(buff(i))
End If
If i < uzunluk - 1 Then
toplamlar = toplamlar + CInt(buff(i))
End If
Next i

onuncuRakam = ((tekToplam * 7) - ciftToplam) Mod 10
onbirinciRakam = (toplamlar Mod 10)

If onuncuRakam <> CInt(buff(uzunluk - 2)) Then
TCKMN = "Hatalý TCKMN (10)"
ElseIf onbirinciRakam <> CInt(buff(uzunluk - 1)) Then
TCKMN = "Hatalý TCKMN (11)!"
Else
TCKMN = ""
End If
End If
End Function
asagidaki kodu Sayfa1 kod bölümüne ekleyiniz:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For i = 2 To 5000
If WorksheetFunction.CountIf(Range("b2:b" & i), Range("b" & i).Value) > 1 or not TCKMN(Cells(i, 2)) ="" then
MsgBox "MÜKERRER KAYIT", vbInformation
Range("b" & i).Value = Empty
End If
Next i
End Sub
 
ismailem' Alıntı:
Alternatif olsun.
modül kısmına şu fonksiyonu ekleyiniz:
Function TCKMN(X As String) As String
Dim buff() As String
'Dim tekToplam, ciftToplam, uzunluk, toplamlar, onuncuRakam, onbirinciRakam, i As Integer
Dim tekToplam, ciftToplam, uzunluk, toplamlar, onuncuRakam, onbirinciRakam, i As Integer
buff = Split(StrConv(X, vbUnicode), Chr$(0))
ReDim Preserve buff(UBound(buff) - 1)
uzunluk = CInt(Application.CountA(buff))
If Len(X) <> 11 Then
TCKMN = "Hatalý TCKMN (11/" & uzunluk & ")!"
ElseIf CInt(buff(uzunluk - 1)) Mod 2 <> 0 Then
TCKMN = "Hatalý TCKMN (11.2)!"
ElseIf CInt(buff(0)) = 0 Then
TCKMN = "Hatalý TCKMN (0)!"
Else
For i = 0 To uzunluk - 1
If i Mod 2 <> 0 And i > 0 And i < 9 Then
ciftToplam = ciftToplam + CInt(buff(i))
ElseIf i < 9 Then
tekToplam = tekToplam + CInt(buff(i))
End If
If i < uzunluk - 1 Then
toplamlar = toplamlar + CInt(buff(i))
End If
Next i

onuncuRakam = ((tekToplam * 7) - ciftToplam) Mod 10
onbirinciRakam = (toplamlar Mod 10)

If onuncuRakam <> CInt(buff(uzunluk - 2)) Then
TCKMN = "Hatalý TCKMN (10)"
ElseIf onbirinciRakam <> CInt(buff(uzunluk - 1)) Then
TCKMN = "Hatalý TCKMN (11)!"
Else
TCKMN = ""
End If
End If
End Function
asagidaki kodu Sayfa1 kod bölümüne ekleyiniz:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For i = 2 To 5000
If WorksheetFunction.CountIf(Range("b2:b" & i), Range("b" & i).Value) > 1 or not TCKMN(Cells(i, 2)) ="" then
MsgBox "MÜKERRER KAYIT", vbInformation
Range("b" & i).Value = Empty
End If
Next i
End Sub
Genişletmek için tıkla ...
Hocam şu hatayı veriyor
 

Ekli dosyalar

  • Ekran Alıntısı.JPG
    Ekran Alıntısı.JPG
    53.7 KB · Görüntüleme: 4
Sayfa1 altına şu kodları eski ile yer değiştirin

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For i = 2 To 5000
If WorksheetFunction.CountIf(Range("b2:b" & i), Range("b" & i).Value) > 1 Then
MsgBox "MÜKERRER KAYIT", vbInformation
Range("b" & i).Value = Empty
End If
Next i

If Intersect(Target, Range(["b2:b5000"])) Is Nothing Then Exit Sub
If Len(Target) <> 11 Then
MsgBox "TC Kimlik numarası 11 Rakamdan oluşmalıdır. Düzeltiniz", vbCritical, "Hatalı !"
Exit Sub

End If
End Sub
 
cems' Alıntı:
Sayfa1 altına şu kodları eski ile yer değiştirin

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For i = 2 To 5000
If WorksheetFunction.CountIf(Range("b2:b" & i), Range("b" & i).Value) > 1 Then
MsgBox "MÜKERRER KAYIT", vbInformation
Range("b" & i).Value = Empty
End If
Next i

If Intersect(Target, Range(["b2:b5000"])) Is Nothing Then Exit Sub
If Len(Target) <> 11 Then
MsgBox "TC Kimlik numarası 11 Rakamdan oluşmalıdır. Düzeltiniz", vbCritical, "Hatalı !"
Exit Sub

End If
End Sub
Genişletmek için tıkla ...
Hocam İlginiz için çok teşekkür ederim. Sizi yoruyorum. Yalnız daha bilgi gireceğim hücreye tıkladığımda uyarı uyarı veriyor. Bunu düzeltmek mümkün mü. acaba.
 

Ekli dosyalar

  • Ekran Alıntısı.JPG
    Ekran Alıntısı.JPG
    76.3 KB · Görüntüleme: 10
Bizim kodların bir özelliği tamamen T.C Kimlik Numarasını denetlemesidir. Sadece 11 rakamından oluşması kontrolü değildir. Kişinin Normal T.C kimlik numarası doğrulama kontrolüdür. Türkiyede böyle bir T.C yoksa uyarır. Hatalı T.C diye uyarı verir. T.C kimlik numarası fonksiyonu ile oluşturulmuştur. Sorun Çözüldü.
 

Ekli dosyalar

Son düzenleme:
ismailem' Alıntı:
Bizim kodların bir özelliği tamamen T.C Kimlik Numarasını denetlemesidir. Sadece 11 rakamından oluşması kontrolü değildir. Kişinin Normal T.C kimlik numarası doğrulama kontrolüdür. Türkiyede böyle bir T.C yoksa uyarır. Hatalı T.C diye uyarı verir. T.C kimlik numarası fonksiyonu ile oluşturulmuştur. Sorun Çözüldü.
Genişletmek için tıkla ...
İsmailem ve cems beyler ilginiz için çok teşekkür ederim. Emeğinize sağlık. Sorun çözüldü. ALLAH razı olsun
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst