aynı kelimeleri çıkartıp kelimeler arasına virgül koyma macrosunu bilen

[x_brknt]

Merhabalar arkadaşlar işim excel ile değil ama excelde yapılabileceğini tahmin ediyorum konu başlığından anlaşılıyodur yinede daha acıklayıcı anlatmam gerekirse sorunum 2 ye ayrılıyor;

1. Elimde alt alta sıralanmış bu tür kelime guruplarını var hücrelerdeki tekrarları kaldırıp teke düşürmem gerekiyo ama bunu yaparken Oil kelimesi kaldırırken aynı zamanda Oil Industrykelimesinin içerisindeki Oil kelimesini kaldırmıyacak

2. si ise yukarıdaki gibi kelimeleri tek bir hüçreye birleştirip aralarına virgül koyması
Yardımınız gerçekten çok makbule geçecek çok uzak olduğum bir konu en aznından 2 sinden bir tanesini bile halledebilmem beni epey bi meşgaleden kurtaracak şimdiden çok teşekkür ederim.

 

[Necdet]

Merhaba,

Dosya eklerseniz kod yazarken veri hazırlama derdinden kurtarırsınız size yardımcı olacak arkadaşı.

 

[x_brknt]

Merhaba,

Dosya eklerseniz kod yazarken veri hazırlama derdinden kurtarırsınız size yardımcı olacak arkadaşa.

Çok özür dilerim düşünemedim her zaman aynı kelimeler olmasada her zaman işime yarayacak bi macro olacak ve çok makbule gececek

 

[Necdet]

Merhaba,

Siz dosya eklemeden önce ben kodları bitirmiştim.

Süz ile yapıldığından mutlaka başlık olmalı.

Sub Sozcuk_Suz()
 
    Dim i As Long
    Dim t As Variant
    
    i = Cells(Rows.Count, "A").End(3).Row
    Application.ScreenUpdating = False
    
    Range("A1:A" & i).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "B1"), Unique:=True
        
    For i = 2 To Cells(Rows.Count, "B").End(3).Row
        If i = 2 Then
            t = Cells(i, "B")
        Else
            t = t & "," & Cells(i, "B")
        End If
    Next i
    Range("B:B").ClearContents
    Range("B1") = t
    
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamdır.", vbInformation, "Necdet YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    
End Sub

 

[Ömer]

Merhaba,

Alternatif olsun. Module kopyalayıp çalıştırın.

Sub Benzersiz_Birlestir()
 
    Dim i As Long, deg As Variant
 
    Application.ScreenUpdating = False
 
    Range("B1").ClearContents
 
    With CreateObject("Scripting.Dictionary")
        For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
            If Not Cells(i, "A") = Empty Then
                deg = UCase(Replace(Replace(Cells(i, "A"), "i", "İ"), "ı", "I"))
                If .exists(deg) = False Then
                    .Add deg, Nothing
                    Range("B1") = Range("B1") & "," & Cells(i, "A")
                End If
            End If
        Next i
    End With
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[x_brknt]

Merhaba,

Siz dosya eklemeden önce ben kodları bitirmiştim.

Süz ile yapıldığından mutlaka başlık olmalı.

Sub Sozcuk_Suz()
 
    Dim i As Long
    Dim t As Variant
    
    i = Cells(Rows.Count, "A").End(3).Row
    Application.ScreenUpdating = False
    
    Range("A1:A" & i).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "B1"), Unique:=True
        
    For i = 2 To Cells(Rows.Count, "B").End(3).Row
        If i = 2 Then
            t = Cells(i, "B")
        Else
            t = t & "," & Cells(i, "B")
        End If
    Next i
    Range("B:B").ClearContents
    Range("B1") = t
    
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamdır.", vbInformation, "Necdet YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    
End Sub

Üstad sen neymişsin ya ben birine razıyken 2 sinide tam istediğim şekle getirdi inan o kadar çok işime yarayacak ki anlatamam ismini her işlemin sonunda bir kez daha hatırlatacak bana gerçekten çok teşekkür ederim. Ömer kardeş sanada çok teşekkür ederim ama belki benim acemiliğimdendir uygulama sırasında hata verdi yinede çok sağol işim halloldu

 

[Necdet]

Üstad sen neymişsin ya ben birine razıyken 2 sinide tam istediğim şekle getirdi inan o kadar çok işime yarayacak ki anlatamam ismini her işlemin sonunda bir kez daha hatırlatacak bana gerçekten çok teşekkür ederim. Ömer kardeş sanada çok teşekkür ederim ama belki benim acemiliğimdendir uygulama sırasında hata verdi yinede çok sağol işim halloldu

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

 

[x_brknt]

Kolay gelsin aylar sonra tekrar geldim Necdet üstadım

kullandığım site keyword şeklini değiştirdi ve senden tekrar yardım dileyeceğim ilk yaptığın macro süperdi yine aynı özelliklerde olacak ama bu sefer ayrı ayrı hücrelerde değil süzülecek sözcük grupları şöyle ki;

[/url]

ilk hali bu şekilde aralarında ki virgüller kalacak sadece tekrarlanan sözcükler silinecek ama daha öncede bahsettiğim gibi cofffee yi silerken coffee shop, daki coffee silinmeyecek yardımcı olacağına eminim şimdiden çok teşekkür ederim

http://bit.ly/c25MCx

 

[Necdet]

Merhaba,

Kodları deneyiniz.
A sütunundaki değerleri B sütununda düzenler. Ancak hücre üzerinde işlem yapacaksanız, yani A sütununda değişiklik yapacaksınız

Cells(i, "B") = b

satırını

Cells(i, "A") = b

olarak değiştiriniz.

Sub Duzenle()
    
    Dim i   As Long, _
        j   As Integer, _
        s, _
        d, _
        a, _
        b
    
    Application.ScreenUpdating = False
    
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
    
        Set d = CreateObject("Scripting.Dictionary")
        s = Split(Cells(i, "A"), ", ")
        
        For j = 0 To UBound(s)
            s(j) = Trim(s(j))
            If Not d.exists(s(j)) Then d.Add s(j), ""
        Next j
        
        a = d.keys
        b = ""
        
        For j = 0 To UBound(a)
            If Len(b) = 0 Then
                b = a(j)
            Else
                b = b & ", " & a(j)
            End If
        Next j
        
        Cells(i, "B") = b
        
        Set a = Nothing
        Set d = Nothing
        
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox "İŞLEM TAMAMDIR....", vbInformation
    
End Sub