Adı,soyadını diğer hücreye Adı Soyadı ayrı ayrı yazılması

[istanbulcahan]

Tekrar Merhaba,

Aşağıdaki kodlar :

AaaBbbbb
AaaBbbCccc
AaaBbbCCC

gibi biçimdeki sözcükleri ayırmaktadır. Kodları inceleyiniz.

Verilerin A sütununda olduğu varsayılmıştır.

Sub Ad_Soyad_Duzenle()
    Dim a
    Dim i       As Long
    Dim j       As Integer
    Dim Ad      As String
    Dim Soyad   As String
    Dim AdSoy   As String
 
    Application.ScreenUpdating = False
 
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
 
        AdSoy = Trim(Cells(i, "A"))
        AdSoy = Duzelt(AdSoy)
        Ad = ""
        Soyad = ""
        a = Split(AdSoy, " ")
 
        If UBound(a) = 0 Then
            Ad = Trim(AdSoy)
        Else
            For j = 0 To UBound(a) - 1
                Ad = Trim(Ad & " " & a(j))
            Next j
            Soyad = Trim(a(UBound(a)))
        End If
 
        Cells(i, "B") = Ad
        Cells(i, "C") = Soyad
 
    Next i
    Application.ScreenUpdating = True
 
    MsgBox "Ad ve Soyad Ayrılmıştır...", vbInformation, "Necdet YEŞERTENER - [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

Function Duzelt(AdSoyad As String)
    Dim d()     As String
    Dim Adet    As Integer
    Dim i       As Integer
    Dim j       As Integer
    Dim Metin   As String
    Dim Sonuc   As String
 
    Metin = " " & AdSoyad
    Adet = Len(Metin)
    ReDim d(Adet + 10)
    j = -1
 
    For i = 2 To Adet
        If Mid(Metin, i, 1) Like "[A-Z#ÇĞİÖŞÜ]" And _
           Mid(Metin, i - 1, 1) Like "[!A-Z#ÇĞİÖŞÜ]" Then
            j = j + 1
            d(j) = " "
        End If
        j = j + 1
        d(j) = Mid(Metin, i, 1)
    Next i
 
    Sonuc = ""
    For i = 0 To UBound(d)
        Sonuc = Sonuc & d(i)
    Next i
 
    Duzelt = Trim(Sonuc)
End Function

Üstadım. Bütün adlar büyükolunca işlem olmuyor.