T.C. Kimlik No Alanı Kontrolü

ByChilavert · 13 Temmuz 2017

Merhaba

Arkadaşlar T.C. Kimlik No alanındaki basamak sayısı 11 mesela ben alt alta T.C. Kimlik Numaralarını girerken eksik yada fazla yazdığım zaman bana renklendirme yaparak uyarmasını istiyorum. Bunu araştırdım ama bir türlü bulamadım. Yardımcı olabilir misiniz.

çıtır · 13 Temmuz 2017

D2 Hücresinde aşağı doğru TC.Kimlik yazılı olduğu varsayılmıştır.
Koşullu biçimlendirme,Yeni kural,Hücreleri bicimlendirmek için formül kullan,
formülü alanına kopyala,dolgu rengi belirle, renklenmesini istediğin alanlar için biçim kopyala.Kolay gelsin

Kod:

=VE(D2<>"";UZUNLUK(D2)<>11)

metin de yazılamasın isterseniz.

Kod:

=YADA(VE(D2<>"";UZUNLUK(D2)<>11);EMETİNSE(D2))

kemal turan · 13 Temmuz 2017

Merhaba,
Renklendirme olmadan da uyarma olabilir.Veri girilecek sütünü seçin
Veri / Doğrulama / İzin verilen seçeneğinden Metin Uzunluğunda Arasında Yada Eşit bölümünden karakter sayısına sınırlama koyabilirsiniz..

hoguz2 · 13 Temmuz 2017

merhaba

mesela a sutununa tc kimlik numaralari giriyorsunuz diyelim asagidaki kodda a1 ile a10 arasında denetim yapiliyor kendinize gore rakami degistirin. TC kimlik in sadece 11 karakter olup olmadigina degil algoritmasina da bakiyor hatali girerseniz uyarir .. sayfa kodu bolumune yazin calismanız sayfa1 deyse sayfa1 icine yazilacak..

iyi calismalar.

Private Sub Worksheet_Change(ByVal Target As Range)
'On Error Resume Next
If Intersect(Target, Range(["a1:a10"])) Is Nothing Then Exit Sub 'denetim yapilmasini istediginiz alan
If Len(Target) <> 11 Then
MsgBox "TC Kimlik numarası 11 Rakamdan oluşmalıdır.", vbCritical, "Hatalı !" 'X
'Target.Text = ""
Exit Sub
End If

Dim mod1 As Integer, mod2 As Integer, TC1 As Integer, TC2 As Integer, TC3 As Integer, TC4 As Integer, TC5 As Integer, TC6 As Integer, TC7 As Integer, TC8 As Integer, TC9 As Integer, TC10 As Integer, TC11 As Integer
TC1 = Mid(Target, 1, 1)
TC2 = Mid(Target, 2, 1)
TC3 = Mid(Target, 3, 1)
TC4 = Mid(Target, 4, 1)
TC5 = Mid(Target, 5, 1)
TC6 = Mid(Target, 6, 1)
TC7 = Mid(Target, 7, 1)
TC8 = Mid(Target, 8, 1)
TC9 = Mid(Target, 9, 1)
TC10 = Mid(Target, 10, 1)
TC11 = Mid(Target, 11, 1)

mod1 = ((((TC1 + TC3 + TC5 + TC7 + TC9) * 7) - (TC2 + TC4 + TC6 + TC8)) Mod 10)
mod2 = ((TC1 + TC2 + TC3 + TC4 + TC5 + TC6 + TC7 + TC8 + TC9 + TC10) Mod 10)

If mod1 = TC10 And mod2 = TC11 Then
'MsgBox Target & " Geçerli TC kimlik numarası", vbInformation, "Bilgilendirme !"
Else
MsgBox Target & " Geçersiz TC kimlik numarası", vbExclamation, "Dikkat !"
End If

End Sub

ByChilavert · 14 Temmuz 2017

Sorunum giderildi. Teşekkürler

yyhy · 26 Eylül 2019

Arkadaşlar macroyu uyguladım ama netice alamadım örnek dosya ekleyebilir misiniz

Seyit Tiken · 26 Eylül 2019

Bu şekilde deneyebilirsiniz

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, Range(["a1:a10"])) Is Nothing Then Exit Sub
If Target.Text = "" Then Exit Sub
If Len(Target) <> 11 Then
MsgBox "TC Kimlik numarası 11 Rakamdan oluşmalıdır.", vbCritical, "Hatalı !"
Target.Select
Exit Sub
End If
End Sub

muratgunay48 · 13 Mart 2021

Seyit Tiken' Alıntı:

Bu şekilde deneyebilirsiniz

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, Range(["a1:a10"])) Is Nothing Then Exit Sub
If Target.Text = "" Then Exit Sub
If Len(Target) <> 11 Then
MsgBox "TC Kimlik numarası 11 Rakamdan oluşmalıdır.", vbCritical, "Hatalı !"
Target.Select
Exit Sub
End If
End Sub

Hocam bunu ben de aramıştım. Emeğinize sağlık.

muratgunay48 · 30 Ocak 2024

Aslında bunu T.C. Kimlik numarasını hatalı yazınca uyarması mümkün mü?
Numaranın bir formatı var. İşte sonu çift olacak gibi.

veyselemre · 30 Ocak 2024

A sütununda doğruluk kontrolu, B sütununda ise 9 rakam yazıldığı zaman son 2 rakamı kendisi hesaplar.

İlgili sayfanın kod kısmına eklenecek,

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [a:b]) Is Nothing Then
        Target.ClearComments
        If Target.Count > 1 Then Exit Sub
        If IsNumeric(Target.Value) Then
            If Not Intersect(Target, [a:a]) Is Nothing Then
                If tcKimlikKontrol(Target.Value) = False Then
                    Target.Select
                    AciklamaEkle
                    Target.Select
                End If
            Else
                If Len(Target.Value) = 9 Then Target.Value = TCKimlikSon2CDKodEkle(Target.Value)
            End If
        End If
    End If
End Sub

Modül e eklenecek

Kod:

Function tcKimlikKontrol(tc)
    Dim i As Byte
    If Len(tc) <> 11 Or Not IsNumeric(tc) Then tcKimlikKontrol = False: Exit Function
    For i = 0 To 9
        t = Val(Mid(tc, i + 1, 1))
        m1 = (m1 + (t * Array(7, -1, 7, -1, 7, -1, 7, -1, 7, 0)(i))) Mod 10
        m2 = (m2 + t) Mod 10
    Next i
    tcKimlikKontrol = Mid(tc, 10, 1) * 1 = m1 And Mid(tc, 11, 1) * 1 = m2
End Function
Function TCKimlikSon2CDKodEkle(tc)
    Dim i As Byte
    If Len(tc) <> 9 Or Not IsNumeric(tc) Then TCKimlikSon2CDKodEkle = tc: Exit Function
    For i = 0 To 8
        t = Val(Mid(tc, i + 1, 1))
        m1 = (m1 + (t * Array(7, -1, 7, -1, 7, -1, 7, -1, 7)(i))) Mod 10
        m2 = (m2 + t) Mod 10
    Next i
    TCKimlikSon2CDKodEkle = tc & m1 & (m1 + m2) Mod 10
End Function

Sub AciklamaEkle()
    With Selection
        .ClearComments
        .AddComment
        .Comment.Visible = True
        .Comment.Text Text:="HATALI TCKİMLİK "
        .Comment.Shape.Select
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .ReadingOrder = xlContext
        .Orientation = xlHorizontal
        .AutoSize = True
    End With
End Sub

necati · 30 Ocak 2024

Merhaba Veyselemre, güzel çalışma olmuş,
Eğer A ve B sütunları haricine bir şey yazılmak istenirse, kısır döngü oluyor.
If Intersect(Target, [a:a]) Is Nothing Then GoTo atla:
If Intersect(Target, [B:B]) Is Nothing Then GoTo atla:

52779 · 30 Ocak 2024

Bilgi amaçlı olarak,
Excel 365 kullanıcıları için, belki faydalı olabilir düşüncesiyle,
daha önce hazırlamış olduğum TC Doğrulaması ile ilgili bir dokumanı paylaşmak istedim...

TC_Dogrulama_365.xlsx dosyasını indir - download

TC_Dogrulama_365.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

TC Doğrulamasındaki kriterler
1 - TC No sadece "RAKAM" lardan oluşmalı.
2 - TC No 11 adet RAKAM dan oluşmalı. TC No 11 haneden oluşmalı.
3 - TC No 0 ile başlamamalı.
4 - Baştan 10. hanedeki Rakamın doğrulanması..
5 - Son Rakamın (Baştan 11. hanedeki rakam) doğrulanması. Tek Sayı olmamalı.

veyselemre · 31 Ocak 2024

necati' Alıntı:
Merhaba Veyselemre, güzel çalışma olmuş,
Eğer A ve B sütunları haricine bir şey yazılmak istenirse, kısır döngü oluyor.
If Intersect(Target, [a:a]) Is Nothing Then GoTo atla:
If Intersect(Target, [B:B]) Is Nothing Then GoTo atla:

Haklısınız odak A:B sütunu olunca orası gözden kaçmış. Yukardaki mesajı düzenledim.

muratgunay48 · 31 Ocak 2024

veyselemre' Alıntı:

A sütununda doğruluk kontrolu, B sütununda ise 9 rakam yazıldığı zaman son 2 rakamı kendisi hesaplar.

İlgili sayfanın kod kısmına eklenecek,

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [a:b]) Is Nothing Then
        Target.ClearComments
        If Target.Count > 1 Then Exit Sub
        If IsNumeric(Target.Value) Then
            If Not Intersect(Target, [a:a]) Is Nothing Then
                If tcKimlikKontrol(Target.Value) = False Then
                    Target.Select
                    AciklamaEkle
                    Target.Select
                End If
            Else
                If Len(Target.Value) = 9 Then Target.Value = TCKimlikSon2CDKodEkle(Target.Value)
            End If
        End If
    End If
End Sub

Modül e eklenecek

Kod:

Function tcKimlikKontrol(tc)
    Dim i As Byte
    If Len(tc) <> 11 Or Not IsNumeric(tc) Then tcKimlikKontrol = False: Exit Function
    For i = 0 To 9
        t = Val(Mid(tc, i + 1, 1))
        m1 = (m1 + (t * Array(7, -1, 7, -1, 7, -1, 7, -1, 7, 0)(i))) Mod 10
        m2 = (m2 + t) Mod 10
    Next i
    tcKimlikKontrol = Mid(tc, 10, 1) * 1 = m1 And Mid(tc, 11, 1) * 1 = m2
End Function
Function TCKimlikSon2CDKodEkle(tc)
    Dim i As Byte
    If Len(tc) <> 9 Or Not IsNumeric(tc) Then TCKimlikSon2CDKodEkle = tc: Exit Function
    For i = 0 To 8
        t = Val(Mid(tc, i + 1, 1))
        m1 = (m1 + (t * Array(7, -1, 7, -1, 7, -1, 7, -1, 7)(i))) Mod 10
        m2 = (m2 + t) Mod 10
    Next i
    TCKimlikSon2CDKodEkle = tc & m1 & (m1 + m2) Mod 10
End Function

Sub AciklamaEkle()
    With Selection
        .ClearComments
        .AddComment
        .Comment.Visible = True
        .Comment.Text Text:="HATALI TCKİMLİK "
        .Comment.Shape.Select
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .ReadingOrder = xlContext
        .Orientation = xlHorizontal
        .AutoSize = True
    End With
End Sub

Hocam öncelikle emeğinize sağlık.
Sub AciklamaEkle()
With Selection
.ClearComments
.AddComment
.Comment.Visible = True
.Comment.Text Text:="HATALI TCKİMLİK "
.Comment.Shape.Select
End With
Kısmı; hücreyi, doğruysa YEŞİL yanlışsa KIRMIZI nasıl yapabiliriz?
Teşekkür ederim.

veyselemre · 1 Şubat 2024

muratgunay48' Alıntı:
Hocam öncelikle emeğinize sağlık.
Kısmı; hücreyi, doğruysa YEŞİL yanlışsa KIRMIZI nasıl yapabiliriz?
Teşekkür ederim.

Açıklama eklemeden hücre rengini doğruysa yeşil değilse kırmızı yapar.
Sayfanın kod kısmındaki kodları aşağıdaki ile değiştirin.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [a:b]) Is Nothing Then
        Target.Interior.Color = xlNone
        If Target.Count > 1 Then Exit Sub
        If IsNumeric(Target.Value) And Target.Value <> "" Then
            If Not Intersect(Target, [a:a]) Is Nothing Then
                If tcKimlikKontrol(Target.Value) = False Then
                    Target.Interior.Color = rgbRed
                Else
                    Target.Interior.Color = rgbPaleGreen
                End If
            Else
                If Len(Target.Value) = 9 Then Target.Value = TCKimlikSon2CDKodEkle(Target.Value)
            End If
        End If
    End If
End Sub

muratgunay48 · 4 Şubat 2024

veyselemre' Alıntı:

Açıklama eklemeden hücre rengini doğruysa yeşil değilse kırmızı yapar.
Sayfanın kod kısmındaki kodları aşağıdaki ile değiştirin.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [a:b]) Is Nothing Then
        Target.Interior.Color = xlNone
        If Target.Count > 1 Then Exit Sub
        If IsNumeric(Target.Value) And Target.Value <> "" Then
            If Not Intersect(Target, [a:a]) Is Nothing Then
                If tcKimlikKontrol(Target.Value) = False Then
                    Target.Interior.Color = rgbRed
                Else
                    Target.Interior.Color = rgbPaleGreen
                End If
            Else
                If Len(Target.Value) = 9 Then Target.Value = TCKimlikSon2CDKodEkle(Target.Value)
            End If
        End If
    End If
End Sub

Hocam emeğinize sağlık.

T.C. Kimlik No Alanı Kontrolü

ByChilavert

çıtır

kemal turan

hoguz2

ByChilavert

yyhy

Seyit Tiken

Uzman

muratgunay48

muratgunay48

veyselemre

Özel Üye

Ekli dosyalar

necati

52779

TC_Dogrulama_365.xlsx dosyasını indir - download

veyselemre

Özel Üye

muratgunay48

veyselemre

Özel Üye

muratgunay48