VBA ile isim soyisim ayırma

[cevoreyiz]

Selam arkadaşlar merhaba benim bir sorunum var

VBA ile isim soyisim ayırması kolay evet boşluktan sonra ayırtıyoruz onu yapabiliyorum internettede her yerde var zaten. Benim sorunum şu

Benim İsim ve Soyisimlerim şu an B sütununda benim istediğim isim B sütununda Soyisimler C sütununda kalsın ama C sütunu dışına D E F G diye devam etmesin malum 2 ismi olanlar olabiliyor.

Yani asıl istediğim B sütunundakileri ilk 1. kelimeden sonrasını C ye yazsın

Yani ismi mesela

ALİ VELİ BAYRAK ise

Ali B de kalsın Veli Bayrak C de kalsın. Yardımcı olabilecek var mı ?

 

[Orion1]

Önce dosyanızı yedekleyiniz.
Buyurun.

Sub isimler59()
Dim isim As String, soyisim As String, i As Long, sonsat As Long
sonsat = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To sonsat
    isim = Left(Range("B" & i).Value, InStr(1, Range("B" & i).Value, " "))
    isim = RTrim(isim)
    soyisim = Right(Range("B" & i).Value, Len(Range("B" & i).Value) - InStr(1, Range("B" & i).Value, " "))
    soyisim = LTrim(soyisim)
    Range("B" & i).Value = isim
    Range("C" & i).Value = soyisim
Next i
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[Korhan Ayhan]

Alternatif,

5 İsme kadar işlem yapar. Dilerseniz arttırabilirsiniz.

Sub Ad_Soyad_Ayir()
    Application.ScreenUpdating = False
    
    Set WF = WorksheetFunction
    Son = Cells(Rows.Count, 1).End(3).Row
    
    For X = 1 To Son
        Veri = Split(Cells(X, 1), " ")
        Select Case UBound(Veri)
            Case 0: Cells(X, 2) = WF.Proper(Veri(0))
            Case 1: Cells(X, 2) = WF.Proper(Veri(0)): Cells(X, 3) = UCase(Veri(1))
            Case 2: Cells(X, 2) = WF.Proper(Veri(0)): Cells(X, 3) = UCase(Veri(1) & " " & Veri(2))
            Case 3: Cells(X, 2) = WF.Proper(Veri(0)): Cells(X, 3) = UCase(Veri(1) & " " & Veri(2) & " " & Veri(3))
            Case 4: Cells(X, 2) = WF.Proper(Veri(0)): Cells(X, 3) = UCase(Veri(1) & " " & Veri(2) & " " & Veri(3) & " " & Veri(4))
        End Select
    Next
    
    Range("A:D").EntireColumn.AutoFit
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Murat OSMA]

Alternatif olsun..

[FONT="Trebuchet MS"][SIZE="2"]Sub Emre()
    Dim i%, dizi, ayır
    For i = 1 To Range("B65536").End(3).Row
        ayır = Split(Cells(i, 2).Value, " ")
        Cells(i, 2).Value = ayır(0): dizi = ayır
        Cells(i, 3).Value = Trim(Replace(Join(dizi, " "), ayır(0), ""))
    Next i
    Erase ayır: Erase dizi: i = Empty
End Sub[/SIZE][/FONT]

 

[ulasoglu]

Son sütuna sadece soyadı ayırmak

iki ya da 3 ismi olanda C sütununa ad(lar),
D sütununa sadece soyadı için makro da neresi değişmeli Teşekkürler

 

[Emir Hüseyin Çoban]

iki ya da 3 ismi olanda C sütununa ad(lar),
D sütununa sadece soyadı için makro da neresi değişmeli Teşekkürler

. . .

Sub kod()
    For i = 1 To Cells(Rows.Count, "B").End(3).Row
        say = Split(Trim(Cells(i, "B")), " ")
        Cells(i, "D") = Split(Cells(i, "B"), " ")(UBound(say))
        Cells(i, "C") = Trim(Replace(Cells(i, "B"), Cells(i, "D"), ""))
    Next i
End Sub

. . .