TC No doğrulama

[ASLAN7410]

Merhaba arkadaşlar herkese hayırlı geceler.

Ekte gönderdiğim excel sayasında formülle TC No doğrulama yaptım, ancak ben bu formülleri vba kısmına alıp B3,D3 veya F3 hücrelerinin birisine TC Noyu yanlış yazdığımda TC No hatalı şeklinde uyarı mesajı vermesini istiyorum.

Forumda ve internette araştırdım, bir kaç tane buldum ancak bunlarda benim istediğim gibi değil, yardım edecek arkadaşlara şimdiden teşekkür ederim.

http://s2.dosya.tc/server/7yodnx/TC_NO_DOGRULAMA.xls.html

 

[ynmcan]

Syn. Aslan;
Aşağıdaki kodu "B3" Hücresi için yazdım siz diğer hücrelere göre çoğaltırsınız.
Ekteki dosyayı inceleyin.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Bir = Mid(Range("B3"), 1, 1)
      İki = Mid(Range("B3"), 2, 1)
            Üç = Mid(Range("B3"), 3, 1)
                 Dört = Mid(Range("B3"), 4, 1)
                        Beş = Mid(Range("B3"), 5, 1)
                              Altı = Mid(Range("B3"), 6, 1)
                              Yedi = Mid(Range("B3"), 7, 1)
                      Sekiz = Mid(Range("B3"), 8, 1)
              Dokuz = Mid(Range("B3"), 9, 1)
        Oon = Mid(Range("B3"), 10, 1)
Onbir = Mid(Range("B3"), 11, 1)

Kriter1 = WorksheetFunction.Sum(Bir, Üç, Beş, Yedi, Dokuz) * 7
          Kriter2 = WorksheetFunction.Sum(İki, Dört, Altı, Sekiz) * 9
                    Kriter3 = WorksheetFunction.Sum(Bir, İki, Üç, Dört, Beş, Altı, Yedi, Sekiz, Dokuz, Oon)
          sonuç1 = Right(WorksheetFunction.Sum(Kriter1, Kriter2), 1)
sonuç2 = Right(WorksheetFunction.Sum(Kriter3), 1)

If Oon = sonuç1 And Onbir = sonuç2 Then
Range("B6") = "TC NO DOĞRU"
Else
Range("B6") = "TC NO YANLIŞ"
End If

End Sub

 

[YUSUF44]

Sayın ynmcan'ın verdiği kodu aşağıdaki gibi değiştirirseniz B3, D3 ve F3 hücresinde değişiklik olduğunda kod çalışır:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B3, D3, F3")) Is Nothing Then Exit Sub
If Target = "" Then
Target.Offset(3, 0) = ""
Else
Bir = Mid(Target, 1, 1)
      İki = Mid(Target, 2, 1)
            Üç = Mid(Target, 3, 1)
                 Dört = Mid(Target, 4, 1)
                        Beş = Mid(Target, 5, 1)
                              Altı = Mid(Target, 6, 1)
                              Yedi = Mid(Target, 7, 1)
                      Sekiz = Mid(Target, 8, 1)
              Dokuz = Mid(Target, 9, 1)
        Oon = Mid(Target, 10, 1)
Onbir = Mid(Target, 11, 1)

Kriter1 = WorksheetFunction.Sum(Bir, Üç, Beş, Yedi, Dokuz) * 7
          Kriter2 = WorksheetFunction.Sum(İki, Dört, Altı, Sekiz) * 9
                    Kriter3 = WorksheetFunction.Sum(Bir, İki, Üç, Dört, Beş, Altı, Yedi, Sekiz, Dokuz, Oon)
          sonuç1 = Right(WorksheetFunction.Sum(Kriter1, Kriter2), 1)
sonuç2 = Right(WorksheetFunction.Sum(Kriter3), 1)

If Oon = sonuç1 And Onbir = sonuç2 Then
Target.Offset(3, 0) = "TC NO DOĞRU"
Else
Target.Offset(3, 0) = "TC NO YANLIŞ"
End If
End If
End Sub

 

[ASLAN7410]

Sayın ynmcan ve YUSUF44 ilginiz için çok teşekkür ederim, ellerinize sağlık, çok işime yaradı.

Vardiyalı çalıştığım için bilgisayar başına yeni geçtim.

Sayın YUSUF44 sizin yazmış olduğunuz kodun alt kısmında küçük bir değişiklik yaptım, kodda aşağıdaki gibi oldu, TC NO yanlış olduğu zaman yazılan hücredeki rakamların silinmesini istiyorum, uğraştım ama yapamadım.
Yardımcı olur musunuz?

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B3, D3, F3")) Is Nothing Then Exit Sub
If Target = "" Then
Target.Offset(3, 0) = ""
Else
Bir = Mid(Target, 1, 1)
      İki = Mid(Target, 2, 1)
            Üç = Mid(Target, 3, 1)
                 Dört = Mid(Target, 4, 1)
                        Beş = Mid(Target, 5, 1)
                              Altı = Mid(Target, 6, 1)
                              Yedi = Mid(Target, 7, 1)
                      Sekiz = Mid(Target, 8, 1)
              Dokuz = Mid(Target, 9, 1)
        Oon = Mid(Target, 10, 1)
Onbir = Mid(Target, 11, 1)

Kriter1 = WorksheetFunction.Sum(Bir, Üç, Beş, Yedi, Dokuz) * 7
          Kriter2 = WorksheetFunction.Sum(İki, Dört, Altı, Sekiz) * 9
                    Kriter3 = WorksheetFunction.Sum(Bir, İki, Üç, Dört, Beş, Altı, Yedi, Sekiz, Dokuz, Oon)
          sonuç1 = Right(WorksheetFunction.Sum(Kriter1, Kriter2), 1)
sonuç2 = Right(WorksheetFunction.Sum(Kriter3), 1)

If Oon = sonuç1 And Onbir = sonuç2 Then
[B]MsgBox "TC NO DOĞRU"
Else
MsgBox "TC NO YANLIŞ"[/B]
End If
End If
End Sub

 

[ynmcan]

Syn. Aslan;
Koda aşağıda kırmızı olan satırları ekleyin .
ekteki dosyayı inceleyin.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B3, D3, F3")) Is Nothing Then Exit Sub
If Target = "" Then
Target.Offset(3, 0) = ""
Else
Bir = Mid(Target, 1, 1)
      İki = Mid(Target, 2, 1)
            Üç = Mid(Target, 3, 1)
                 Dört = Mid(Target, 4, 1)
                        Beş = Mid(Target, 5, 1)
                              Altı = Mid(Target, 6, 1)
                              Yedi = Mid(Target, 7, 1)
                      Sekiz = Mid(Target, 8, 1)
              Dokuz = Mid(Target, 9, 1)
        Oon = Mid(Target, 10, 1)
Onbir = Mid(Target, 11, 1)

Kriter1 = WorksheetFunction.Sum(Bir, Üç, Beş, Yedi, Dokuz) * 7
          Kriter2 = WorksheetFunction.Sum(İki, Dört, Altı, Sekiz) * 9
                    Kriter3 = WorksheetFunction.Sum(Bir, İki, Üç, Dört, Beş, Altı, Yedi, Sekiz, Dokuz, Oon)
          sonuç1 = Right(WorksheetFunction.Sum(Kriter1, Kriter2), 1)
sonuç2 = Right(WorksheetFunction.Sum(Kriter3), 1)

If Oon = sonuç1 And Onbir = sonuç2 Then
MsgBox "TC NO DOĞRU"
Else
MsgBox "TC NO YANLIŞ"
[COLOR="Red"]Target = ""
Target.Activate[/COLOR]
End If
End If
End Sub

 

[ASLAN7410]

Sayın ynmcan çok teşekkür ederim, şimdi tam istediğim gibi oldu ellerinize sağlık, hayırlı akşamlar, hayırlı kandiller.