TC Kimlik No ve isimleri Birbirinden Ayırma

[Mikdad]

Selamun Aleykum dostlarım, aşağıdaki formatta a2 hücresinde isim tc yazılı listem var benim tc ve isimleri birbirinden ayırmam lazım. metni sutunlara dönüştür dediğim zaman ayırıyor ama iki isimli kişilerde sorun çıkıyor. Bu konuda yardımcı olur musunuz?

Süleyman AĞIRMAN 12345678911

Esra AĞIRMAN 12345678911

Furkan AĞIRMAN 12345678911

Bahar KAYA 12345678911

Rozalin KAYA 12345678911

Zeynep Kamile KAYA 12345678911

 

[asdsxx]

dosyayı incele

 

[Mahir64]

Merhaba,

=ARA(9,99999999999999E+307;--SAĞDAN(A2;SATIR($1:$1024)))

deneyiniz.

 

[Mikdad]

dosyayı incele

Hocam bu şekilde sıkıntısız ayırdı. peki adı soyadı ve tc sini 3 parçaya bölebilir miyiz.
yani adı ayrı sutunda soyadı ayrı sutunda tc si ayrı sutunda.

 

[Mikdad]

Ekte Şablonu Sunuyorum. daha iyi anlaşılır.

 

[YUSUF44]

B2 formülü:

=KIRP(EĞER(UZUNLUK(KIRP(A2))-UZUNLUK(YERİNEKOY(KIRP(A2);" ";""))<2;SOLDAN(KIRP(A2);BUL(" ";KIRP(A2))-1);SOLDAN(KIRP(A2);BUL(" ";KIRP(A2);BUL(" ";KIRP(A2))))))

C2 formülü:

=KIRP(YERİNEKOY(YERİNEKOY(KIRP(A2);B2;"");D2;""))

D2 formülü:

=SAĞDAN(KIRP(A2);11)*1

E2 formülü:

=KIRP(B2&" "&C2)

 

[veyselemre]

Sub adSoyadTcAyir()
    For i = 2 To Cells(Rows.Count, 1).End(3).Row
        ver = Split(Cells(i, "A"), " ")
        tc = ver(UBound(ver))
        ad = ""
        If UBound(ver) = 2 Then
            ad = ver(0)
            soyad = ver(1)
        Else
            For ii = 0 To UBound(ver) - 2
                ad = ad & ver(ii) & " "
            Next ii
            ad = Trim(ad)
            soyad = ver(UBound(ver) - 1)
        End If
        adSoyad = ad & " " & soyad
        Cells(i, "B") = ad
        Cells(i, "C") = soyad
        Cells(i, "D") = tc
        Cells(i, "E") = adSoyad
    Next
End Sub

 

[Mikdad]

Veyselemre hocam Allah Razı Olsun tam istediğim gibi . başka arkadaşların da ihtiyacı olur diye son şablonu paylaşıyorum. yüreğinize sağlık

 

[halit3]

Bir kod da ben yazmıştım alternatif olsun

Sub aktar()

sayf1 = "Rapor"

Worksheets(sayf1).Range("B2:E" & Rows.Count).ClearContents

For r = 2 To Worksheets(sayf1).Cells(Rows.Count, "A").End(3).Row
aranan = Trim(Worksheets(sayf1).Cells(r, "A").Value)
deg1 = Split(aranan, " ")

If UBound(deg1) = 4 Then
Cells(r, 2).Value = deg1(0) & " " & deg1(1)
Cells(r, 3).Value = deg1(2) & " " & deg1(3)
Cells(r, 4).Value = deg1(4)
Cells(r, 5).Value = deg1(0) & " " & deg1(1) & " " & deg1(2) & " " & deg1(3)
GoTo atla2
MsgBox "Bu kişinin iki adı ve iki soyadı var "
End If


If UBound(deg1) > 2 Then GoTo atla1
If UBound(deg1) > 0 Then
For j = 0 To UBound(deg1)
Cells(r, j + 2).Value = deg1(j)
Next j
Cells(r, 5).Value = deg1(0) & " " & deg1(1)

GoTo atla2
atla1:

msg1 = MsgBox(aranan & Chr(10) & Chr(10) & "İki isim için       EVET  tıklayınız. " & Chr(10) & Chr(10) & _
"İki Soyad için   HAYIR  tıklayınız. ", vbYesNo + vbInformation, "u y a r ı !")

If msg1 = vbYes Then
Cells(r, 2).Value = deg1(0) & " " & deg1(1)
Cells(r, 3).Value = deg1(2)
Cells(r, 4).Value = deg1(3)
Cells(r, 5).Value = deg1(0) & " " & deg1(1) & " " & deg1(2)
End If

If msg1 = vbNo Then
Cells(r, 2).Value = deg1(0)
Cells(r, 3).Value = deg1(1) & " " & deg1(2)
Cells(r, 4).Value = deg1(3)
Cells(r, 5).Value = deg1(0) & " " & deg1(1) & " " & deg1(2)
End If

atla2:
atla3:
End If


Next r
MsgBox " Düzenleme Tamanlanmıştır..."

End Sub

 

[Erdem Akdemir]

Formül yada makro kullanmadan Hızlı Doldurma ile yapabilirsiniz. Ben denedim çalıştı.
İlk 2 satırı elle yazın daha sonra hızlı doldurma'ya tıklayın.

 

[çıtır]

Dosyanız.

 

[metin_0606]

Sub adSoyadTcAyir()
    For i = 2 To Cells(Rows.Count, 1).End(3).Row
        ver = Split(Cells(i, "A"), " ")
        tc = ver(UBound(ver))
        ad = ""
        If UBound(ver) = 2 Then
            ad = ver(0)
            soyad = ver(1)
        Else
            For ii = 0 To UBound(ver) - 2
                ad = ad & ver(ii) & " "
            Next ii
            ad = Trim(ad)
            soyad = ver(UBound(ver) - 1)
        End If
        adSoyad = ad & " " & soyad
        Cells(i, "B") = ad
        Cells(i, "C") = soyad
        Cells(i, "D") = tc
        Cells(i, "E") = adSoyad
    Next
End Sub

Yunus emre hocam örneğin HASAN HÜSEYİN BARAN gibi formatlarda kayma oluyor buna bir çözüm bilabilirmiyiz

 

[metin_0606]

Sub adSoyadTcAyir()
    For i = 2 To Cells(Rows.Count, 1).End(3).Row
        ver = Split(Cells(i, "A"), " ")
        tc = ver(UBound(ver))
        ad = ""
        If UBound(ver) = 2 Then
            ad = ver(0)
            soyad = ver(1)
        Else
            For ii = 0 To UBound(ver) - 2
                ad = ad & ver(ii) & " "
            Next ii
            ad = Trim(ad)
            soyad = ver(UBound(ver) - 1)
        End If
        adSoyad = ad & " " & soyad
        Cells(i, "B") = ad
        Cells(i, "C") = soyad
        Cells(i, "D") = tc
        Cells(i, "E") = adSoyad
    Next
End Sub

Veysel emre hocam format şu şekilde olursa 12345678911 ALİ AKDENİZ ve 123456789011 HASAN HUSEYİN BARAN makroyu nasıl revize etmemiz gerekiyor

 

[muzaffer.sm]

Bir alternatif kodda ben vereyim.
Sabitleşmiş bir fonksiyon.

Public Function SplitText1(hwRng As Range, pIsNumber As Boolean) As String

Dim xLen As Long
Dim xStr As String
xLen = VBA.Len(hwRng.Value)
For i = 1 To xLen
xStr = VBA.Mid(hwRng.Value, i, 1)
If ((VBA.IsNumeric(xStr) And pIsNumber) Or (Not (VBA.IsNumeric(xStr)) And Not (pIsNumber))) Then
SplitText1 = SplitText1 + xStr
End If
Next
End Function

a2 ve sonrasındaki verilerin olduğuna göre

=SplitText(A2;0) B sütuna isim gelir B sütununda formülu uygulayın.
=SplitText(A2;1) c sütuna isim TC ler gelir. C sütununda olmak üzere formülü uygulayın