Hücre içinde bir den fazla tekrarlanan kelimeleri çıkartmak

[aacanakova]

Nereleri değiştirmem gerektiğini bulamadım Koray hocam o yüzden yazdım.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Metin_Icindeki_Tekrar_Edenleri_Kaldir()
    Dim Dizi As Object, Veri As Variant, Son As Long, X As Long, Say As Long
    Dim Metin As Variant, Y As Integer, Sonuc As String, Zaman As Double
    
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son = 1 Then Son = 2
    
    Veri = Range("A1:A" & Son).Value
    
    ReDim Liste(1 To UBound(Veri), 1 To 1)
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) <> "" Then
            Metin = Split(WorksheetFunction.Trim(Replace(Replace(Veri(X, 1), ":", " "), ",", " ")), " ")
            For Y = LBound(Metin) To UBound(Metin)
                If IsNumeric(Metin(Y)) And Len(Metin(Y)) >= 10 Then
                    If Not Dizi.Exists("," & Metin(Y)) Then Dizi.Add "," & Metin(Y), Nothing
                Else
                    If Not Dizi.Exists(Metin(Y)) Then Dizi.Add Metin(Y), Nothing
                End If
            Next
            
            Sonuc = Join(Dizi.Keys, " ")
            
            Dizi.RemoveAll
            
            Say = Say + 1
            Liste(Say, 1) = Sonuc
            
            Sonuc = ""
        End If
    Next

    If Say > 0 Then Range("B1").Resize(Say, 1) = Liste
    
    Set Dizi = Nothing
    
    MsgBox "Tekrar eden veriler temizlenmiştir." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[aacanakova]

Eyvallah hocam ellerine emeğine sağlık , Bir de ben anlayabilsem şu yazdıklarınızı )

 

[Korhan Ayhan]

Elbet bir gün oda olur..

 

[SATYON]

Örnek dosya yok, hücre içerisinde alt+enter kullanıldıysa hatalı sonuç verecektir.

Sub TEST()
    For i = 2 To Cells(Rows.Count, 1).End(3).Row
        bl = Split(Cells(i, 1))
        For ii = LBound(bl) To UBound(bl) - 1
            al = bl(ii)
            If Not IsNumeric(al) Then
                For iii = ii + 1 To UBound(bl)
                    If al = bl(iii) Then bl(iii) = ""
                Next iii
            End If
        Next ii
        Cells(i, 2) = WorksheetFunction.Trim(Join(bl))
    Next i
End Sub

Veysel bey merhaba, I kolonunda aynı hücrelerde tekrarlayan verilerim var ve shift enter ile alt alta görünüyorlar. makronuzu buna göre nasıl uyarlayabiliriz?