TC numaralarını ayırma

[student99]

Merhaba, elimde bir liste var ve her bir hücrede, ad, soyad, doğum tarihi, doğum yeri, eğitim seviyesi ve tc numaraları var. Bu liste içerisindeki tc numaralarını başka bir hücreye ayırmak istiyorum. Fakat yukarıdaki bilgilerin hücre içerisindeki sıralanışı düzenli değil.

Örnek veri:

ALİ OSMAN TEZCAN 1983 KAYSERİ 46257896521 LİSANS
OSMAN SERHAT ÖZTÜRK 42979298650 İSTANBUL YÜKSEK LİSANS 1985
FATMA BALCI LİSE ANKARA 39875523670 1988

bu hücrelerden TC numaralarını başka bir hücreye nasıl ayırabilirim? Yardımlarınız için teşekkürler...

 

[Erdal]

Merhabalar
TC numaraları 11 hanelidir. Buna göre ayırabilirsiniz. Saygı ve selam ile ...

 

[student99]

TC numaraları

Merhaba,

11 haneli rakamların nasıl ayrılabileceğini gösterebilir misiniz? Teşekkür ederim...

 

[Zeki Gürsoy]

Merhaba,

Örnek bir dosya eklerseniz makro ile çözümü çok kolay olacaktır.

 

[Erdal]

Merhaba,

11 haneli rakamların nasıl ayrılabileceğini gösterebilir misiniz? Teşekkür ederim...

Örnek dosya ekleyebilir misiniz?

 

[student99]

Örnek Dosya

dosyayı eke koydum, ilginiz için teşekkürler...

 

[halit3]

kod:

Private Sub CommandButton1_Click()

son = Cells(Rows.Count, "a").End(3).Row
Range("B2:B" & son).ClearContents

For i = 2 To son
aranan1 = Cells(i, 1).Value
For j = 1 To Len(aranan1)
bulunan = Mid(aranan1, j, 11)
If IsNumeric(bulunan) = True Then
If IsNumeric(Left(bulunan, 1)) = True Then
If IsNumeric(Right(bulunan, 1)) = True Then
Cells(i, 2).Value = bulunan
Exit For
End If
End If
End If
Next j
Next i
End Sub

 

[Necdet]

Merhaba,

Bende uğraşmıştım.

Sub tcno()
    
    Dim i   As Long, _
        j   As Integer, _
        d
    
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
        d = Split(Cells(i, "A"), " ")
        For j = 0 To UBound(d)
            If IsNumeric(d(j)) And Len(d(j)) = 11 Then
                Cells(i, "B") = d(j)
                Exit For
            End If
        Next j
        
    Next i
    
End Sub

 

[student99]

teşekkürler

çok teşekkür ederim, kodlar işe yaradı, beni büyük zahmetten kurtardınız, elinize sağlık, iyi ki varsınız...

 

[Erdal]

Merhabalar
Alternatif olması açısından dosyayı ekldim. Umarım işinize yarar. Saygı ve selam ile...

 

[Zeki Gürsoy]

"Regular Expression" olmazsa bu konunun tadı çıkmaz.

Sub test()
    Set reg = CreateObject("VBScript.Regexp")
    reg.Pattern = "\b\d{11}\b" [COLOR=DarkGreen] ' Ömer bey' e teşekkürler[/COLOR]
    
    For sat = 2 To [a1000].End(3).Row
        Set m = reg.Execute(Cells(sat, "a"))
        If m.Count > 0 Then Cells(sat, "b") = m(0)
    Next
End Sub