Mükerrer T.C Kimlik girişi.

[sedat2161]

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.

 

[cems]

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

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

 

[sedat2161]

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

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

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.

 

[ismailem]

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

 

[sedat2161]

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

Hocam şu hatayı veriyor

 

[cems]

Sayfa1 altına şu kodları eski ile yer değiştirin

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

 

[sedat2161]

Sayfa1 altına şu kodları eski ile yer değiştirin

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

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.

 

[ismailem]

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ü.

 

[sedat2161]

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ü.

İsmailem ve cems beyler ilginiz için çok teşekkür ederim. Emeğinize sağlık. Sorun çözüldü. ALLAH razı olsun