• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

TC Kimlik No ve isimleri Birbirinden Ayırma

Mikdad

Mikdad

Altın Üye
Katılım
5 Ocak 2006
Mesajlar
333
Excel Vers. ve Dili
365 Türkçe
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
 
Merhaba,
Kod: 
=ARA(9,99999999999999E+307;--SAĞDAN(A2;SATIR($1:$1024)))
deneyiniz.
 
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)
 
Kod: 
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
 
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
 

Ekli dosyalar

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

PHP: 
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



Yeni Bit Eşlem Resmi (3).jpg
 

Ekli dosyalar

Son düzenleme:
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.
 
veyselemre' Alıntı:
Kod: 
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
Genişletmek için tıkla ...
Yunus emre hocam örneğin HASAN HÜSEYİN BARAN gibi formatlarda kayma oluyor buna bir çözüm bilabilirmiyiz
 
veyselemre' Alıntı:
Kod: 
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
Genişletmek için tıkla ...
Veysel emre hocam format şu şekilde olursa 12345678911 ALİ AKDENİZ ve 123456789011 HASAN HUSEYİN BARAN makroyu nasıl revize etmemiz gerekiyor
 
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






 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst