Kelime ayırma

[Ziynettin]

Merhaba,

Ekli dosyada B sütunundaki verileri E sütununa benzersiz, F sütununa da sıra numaraların yazdırmak. Konu ile yardımcı olacak arkadaşlara şimdiden teşekkür ederim.

http://www.dosya.tc/server5/exnmc2/Ornek_Benzersiz_.xlsx.html

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz?

Not : B sütunundaki değerleri boşluklara göre ayırdım. Örnekte görüldüğü üzere Nokta ve Virgülleri sildim. Başka değerler varsa onlarında silinmesi gerekibilir.

Sub Duzenle()

    Dim i   As Long, _
        j   As Integer, _
        Szk, _
        d, _
        a1
    
    Set d = CreateObject("Scripting.Dictionary")
    Range("E2:F" & Rows.Count).ClearContents
    
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
        Szk = Split(Trim(Cells(i, "B")), " ")
        For j = 0 To UBound(Szk)
            Szk(j) = Trim(Replace(Replace(Szk(j), ",", ""), ".", ""))
            If Not d.exists(Szk(j)) Then
                d.Add Szk(j), Cells(i, "A")
            Else
                d.Item(Szk(j)) = d.Item(Szk(j)) & " " & Cells(i, "A")
            End If
        Next j
    Next i
    
    a1 = d.keys
    Range("E2").Resize(d.Count, 1) = Application.Transpose(a1)
    a1 = d.items
    Range("F2").Resize(d.Count, 1) = Application.Transpose(a1)
    
End Sub

 

[Ziynettin]

Merhaba Necdet Bey,
Ellerinize sağlık, çok teşekkür ederim.

 

[Necdet]

Güle güle kullanınız.