Excel'de Ad Soyad Ayırma Makro Kodu

[Bülent]

Aşağıdaki kod ile A sütununa birleşik yazılan ad ve soyadları, B sütununa isimler, C sütununa soyadı gelecek şekilde ayırabilirsiniz:

Kod Seç Expand

Sub EXCELCE_ADSOYAD_AYIR()
Dim BULENT, EXCELCE, ad As Long
Dim DEGIS, ADI As String
Dim AYIR() As String
Columns("B:C").ClearContents
'TÜRKÇE KARAKTER DEĞİŞTİR-EXCELCE.NET:
For BULENT = 1 To Cells(65536, 1).End(xlUp).Row
    DEGIS = Cells(BULENT, 1).Value
    DEGIS = VBA.Replace(DEGIS, "Ç", "C")
    DEGIS = VBA.Replace(DEGIS, "ç", "c")
    DEGIS = VBA.Replace(DEGIS, "Ğ", "G")
    DEGIS = VBA.Replace(DEGIS, "ğ", "g")
    DEGIS = VBA.Replace(DEGIS, "İ", "I")
    DEGIS = VBA.Replace(DEGIS, "ı", "i")
    DEGIS = VBA.Replace(DEGIS, "Ö", "O")
    DEGIS = VBA.Replace(DEGIS, "ö", "o")
    DEGIS = VBA.Replace(DEGIS, "Ü", "U")
    DEGIS = VBA.Replace(DEGIS, "ü", "u")
    DEGIS = VBA.Replace(DEGIS, "Ş", "S")
    DEGIS = VBA.Replace(DEGIS, "ş", "s")
    'YAZIM DÜZENİ-EXCELCE.NET:
    DEGIS = StrConv(DEGIS, vbProperCase)
    Cells(BULENT, 1).Value = DEGIS
Next BULENT
'AYIR:
    For EXCELCE = 1 To Cells(65536, 1).End(xlUp).Row
    AYIR = Split(Cells(EXCELCE, 1), " ")
    KACBOSLUKVAR = UBound(AYIR)
    If KACBOSLUKVAR = 0 Then
        Cells(EXCELCE, 2).Value = Cells(EXCELCE, 1)
    Else
        Cells(EXCELCE, 3).Value = AYIR(KACBOSLUKVAR)
        For ad = 0 To KACBOSLUKVAR - 1
           ADI = ADI & AYIR(ad) & " "
        Next ad
        Cells(EXCELCE, 2).Value = ADI
    End If
        ADI = ""
    Next EXCELCE
    MsgBox "İşlem tamamlandı", vbInformation, "Excelce.Net"
End Sub