aynı hücre içindeki değerleri tek yapma

[oydemir]

arkadaşlar dosyamda
w2 Hücresinde boşluklara ayrılmış tekrar edilmiş aynı değerler sahip bilgiler var.
benim yapmak istediğim w2 hücresindeki değerlerin tek olması.
Bunu w kolonunda yapmak istiyorum. Teşekkürler

 

[ÖmerFaruk]

Excel verisyonunuz nedir?
Formülle çözüm şart mıdır? VBA olmaz mı?

 

[ÖmerFaruk]

Excel 365 kullanıyorsanız eğer
=METİNBİRLEŞTİR(" ";1;BENZERSİZ(SÜTUNA(METİNBÖL(W2;" "))))

 

[oydemir]

VBA olmaz mı daha iyi olur

 

[oydemir]

VBA olmaz mı kullanıyorum.

 

[ÖmerFaruk]

Sayfanın KOD kısmına yapıştırın. W2:Wxx aralığında değişiklik yaptıkça bir sonraki sütuna tekrarsız olarak metin döndürür.

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("W2:W" & Rows.Count)) Is Nothing Then
    Application.EnableEvents = False
    Dim dict
    Set dict = CreateObject("Scripting.Dictionary")
    Dizim = Split(Target.Value)
    For i = LBound(Dizim) To UBound(Dizim)
        If Not dict.Exists(Dizim(i)) Then
            dict.Add Dizim(i), 0
        End If
    Next i
    Target.Offset(, 1) = Join(dict.keys, " ")
    ' Eğer farklı bir sütuna yazmak istiyorsanız üstteki satırda değişiklik yapmanız yetecektir.
    Application.EnableEvents = True
End If
End Sub

 

[Necdet]

Merhaba,
Değişik yöntemler kullanılabilinir.
Scripting.Dictionary bilmeyenler için alternatif olsun.

Sub Duzenle()

Dim i   As Long
Dim j   As Integer
Dim arr As Variant
Dim col As Integer
Dim t   As Variant

col = Cells(1, Columns.Count).End(1).Column + 1
Application.ScreenUpdating = False

For i = 2 To Cells(Rows.Count, "W").End(3).Row
    arr = Split(Cells(i, "W"), " ")
    Cells(1, col).Resize(UBound(arr) + 1, 1) = Application.WorksheetFunction.Transpose(arr)
    j = Cells(Rows.Count, col).End(3).Row
    Range(Cells(1, col), Cells(j, col)).RemoveDuplicates Columns:=1, Header:=xlNo
    j = Cells(Rows.Count, col).End(3).Row
    Range(Cells(1, col), Cells(j, col)).Sort Key1:=Cells(1, col)
    t = Application.Transpose(Range(Cells(1, col), Cells(j, col)))
    Cells(i, "W") = Join(t, " ")
Next i

Columns(col).ClearContents
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır...."

End Sub

 

[tahsinanarat]

Function TekilKelimeler(ByVal Metin As String) As String
Dim D As Object: Set D = CreateObject("Scripting.Dictionary")
Dim Kelimeler() As String: Kelimeler = Split(Metin, " ")
Dim K As Variant, Sonuc As String

For Each K In Kelimeler
If Len(K) > 0 Then
If Not D.exists(K) Then D.Add K, 1
End If
Next

For Each K In D.Keys
Sonuc = Sonuc & K & " "
Next

TekilKelimeler = Trim(Sonuc)
End Function
v2 hücresine;
=Tekilkelimeler(W2)
Formül ile yardımcı sutunlar kullanmak gerekiyor gibi, çok zahmetli bir iş gibi görünüyor.

 

[oydemir]

Teşekkürler elinize sağlık