ad soyad ayırma makrosu hakkında

[drummers]

Sub adsoyadayir()
Range("C265536").ClearContents
For i = 2 To Cells(65536, 1).End(xlUp).Row
a = Split(Cells(i, 2), " ")
deg = "": deg2 = ""

If UBound(a) = 0 Then
Cells(i, "D").Value = Cells(i, "C").Value
ElseIf UBound(a) = 1 Then
Cells(i, "C").Value = a(0)
Cells(i, "D").Value = a(1)
Else
For k = 0 To UBound(a)
If k <= 1 Then
deg = deg & " " & a(k)
Cells(i, "C").Value = Right(deg, Len(deg) - 1)
Else
deg2 = deg2 & " " & a(k)
Cells(i, "D").Value = Right(deg2, Len(deg2) - 1)
End If
Next k
End If

Next
MsgBox "İşlem Tamamdır."
End Sub







böyle bi makro ile ad soyad ayırmaktayım.......

fakat benim istediğim aynen şudur

benzer isimler olduğunda ÖRNEK:

HASAN ÇAL HASAN ÇAL
HASAN GÜL HASAN. GÜL
HASAN YELDEN HASAN.. YELDEN


isimlerin yanlarına (.) nokta koyması bu makroya bunu nasıl ilave ederiz

teşekkürler

 

[Korhan Ayhan]

Selamlar,

3 isimli ve aynı ismi içeren kişilerde nasıl bir sonuç istiyorsunuz?

 

[drummers]

sonucun aynen ekli dosyadaki gibi olmasını istiyorum

 

[Korhan Ayhan]

Selamlar,

Kullandığınız kodu aşağıdaki şekilde değiştirip denermisiniz.

Sub adsoyadayir()
    Range("C2:D65536").ClearContents
    For i = 2 To Cells(65536, 2).End(xlUp).Row
    a = Split(Cells(i, 2), " ")
    deg = "": deg2 = ""
    
    If UBound(a) = 0 Then
    Cells(i, "D").Value = Cells(i, "C").Value
    ElseIf UBound(a) = 1 Then
    Say = WorksheetFunction.CountIf([C:C], "*" & a(0) & "*")
    If Say > 0 Then
    Cells(i, "C").Value = a(0) & WorksheetFunction.Rept(".", Say)
    Cells(i, "D").Value = a(1)
    Else
    Cells(i, "C").Value = a(0)
    Cells(i, "D").Value = a(1)
    End If
    Else
    For k = 0 To UBound(a)
    If k <= 1 Then
    deg = deg & " " & a(k)
    Cells(i, "C").Value = Right(deg, Len(deg) - 1)
    Else
    deg2 = deg2 & " " & a(k)
    Cells(i, "D").Value = Right(deg2, Len(deg2) - 1)
    End If
    Next k
    End If
    
    Next
    MsgBox "İşlem Tamamdır."
End Sub

 

[drummers]

elinize sağlık teşekkürler