ARKA ARKAYA GELEN ÇİFT İSİMLERİ TEKE DÜŞÜRME

[EMRE YALÇIN]

Merhaba. Örnek dosyada ki ardışık gelen isimleri nasıl teke düşürebilirim

 

[YUSUF44]

Aşağıdaki makroyu dener misiniz?

Sub tekle()
son = Cells(Rows.Count, "A").End(3).Row
For i = 2 To son
    veri = Split(Cells(i, "A"), " ")
    ad = ""
    For j = 1 To UBound(veri)
        If veri(j) = veri(0) Then
            For k = 0 To j - 1
                If ad = "" Then
                    ad = veri(k)
                Else
                    ad = ad & " " & veri(k)
                End If
            Next
            Cells(i, "B") = ad
            k = UBound(veri)
            j = UBound(veri)
        End If
    Next
    If Cells(i, "B") = "" Then Cells(i, "B") = Cells(i, "A")
Next
End Sub

 

[bmutlu966]

Formülle yapmak isterseniz de ekli dosyayı kullanırsınız.

 

[EMRE YALÇIN]

Formülle yapmak isterseniz de ekli dosyayı kullanırsınız.

İŞE YARADI .Emeğinize sağlık

 

[EMRE YALÇIN]

Aşağıdaki makroyu dener misiniz?

Sub tekle()
son = Cells(Rows.Count, "A").End(3).Row
For i = 2 To son
    veri = Split(Cells(i, "A"), " ")
    ad = ""
    For j = 1 To UBound(veri)
        If veri(j) = veri(0) Then
            For k = 0 To j - 1
                If ad = "" Then
                    ad = veri(k)
                Else
                    ad = ad & " " & veri(k)
                End If
            Next
            Cells(i, "B") = ad
            k = UBound(veri)
            j = UBound(veri)
        End If
    Next
    If Cells(i, "B") = "" Then Cells(i, "B") = Cells(i, "A")
Next
End Sub

Harika oldu teşekkürler.

 

[Korhan Ayhan]

Bu da "RegExp" ile alternatif olsun..

Kullanıcı tanımlı fonksiyon..

=UNIQUE_WORDS(A2)

Option Explicit

Function UNIQUE_WORDS(My_Range As Range)
    Application.Volatile True
    With VBA.CreateObject("VBScript.RegExp")
        .Pattern = "^(.+)\s*\1$"
        .Global = True
        .MultiLine = True
        UNIQUE_WORDS = .Replace(My_Range.Value, "$1")
    End With
End Function