Satırdaki verileri birleştirip tekrarlanan kelimeleri silme

[cockatiel]

Selamlar.
Herbir satırı tek satırda arada "," işareti ile yanyana getirip satır içerindeki aynı kelimeleri teke indirmek istiyorum.
Örneğin; cargo 111111 cargo222222 ayrı sütunlarda yazıyor.Bunu tek satırda Cargo 111111,222222 şeklinde toplamak istiyorum.

Yalnız bu şekilde sütun ve satır sayısı fazla olduğu için toplu şekilde yapmam gerekiyor.Birde örnekteki "cargo" kelimesi birinci satırda sekizinci hücredeyse onuncu satırda ikinci hücrede olabiliyor.Yardımcı olur musunuz?

 

[Asri]

Makrolu çözüm;

Aynı dosya içinde farklı sayfalarda da kullanabilirsiniz.
Satır, Sütun sınırlaması yoktur.

Sub birlestir()
    Set sh = ActiveSheet
    sh.Range("F:F").Clear
 
    If WorksheetExists("LISTEXXX") Then
       Application.DisplayAlerts = False
       Sheets("LISTEXXX").Delete
       Application.DisplayAlerts = True
    End If
    Set shliste = Sheets.Add(, Sheets(Sheets.Count))
    shliste.Name = "LISTEXXX"
 
    sonsatir = sh.Cells(sh.Rows.Count, "A").End(3).Row
    sonsutun = sh.Cells(2, sh.Columns.Count).End(xlToLeft).Column
    For i = 2 To sonsatir
       a = a
       For j = 1 To sonsutun
            veri = Replace(sh.Cells(i, j).Value, "  ", " ")
            If InStr(veri, " ") > 0 Then kelime = Split(veri, " ")
            If InStr(veri, " ") > 0 Then kelime = Split(veri, " ")
            Set varmi = shliste.Range("A:A").Find(kelime(0), , xlValues, xlWhole)
            If Not varmi Is Nothing Then
              satir = varmi.Row
              shliste.Cells(satir, "B").Value = shliste.Cells(satir, "B").Value & kelime(1) & ","
            Else
              satir = shliste.Cells(shliste.Rows.Count, "A").End(3).Row + 1
              shliste.Cells(satir, "A").Value = kelime(0)
              shliste.Cells(satir, "B").Value = veri & ","
            End If
       Next j
       satir = shliste.Cells(shliste.Rows.Count, "A").End(3).Row - 1
       If satir > 0 Then
            For k = satir To 2 Step -1
                shliste.Cells(k, "B").Value = shliste.Cells(k, "B").Value & shliste.Cells(k + 1, "B").Value
                shliste.Cells(k + 1, "A").Clear
                shliste.Cells(k + 1, "B").Clear
            Next k
            satir = shliste.Cells(shliste.Rows.Count, "C").End(3).Row + 1
            shliste.Cells(satir, "C").Value = shliste.Cells(2, "B").Value
            shliste.Cells(2, "B").Clear
            shliste.Cells(2, "A").Clear
       End If
    Next i

    shliste.Columns("C:C").Copy sh.Columns("F:F")
 
    Application.DisplayAlerts = False
    Sheets("LISTEXXX").Delete
    Application.DisplayAlerts = True
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
   On Error Resume Next
   WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error Resume Next
   On Error GoTo 0
End Function

 

[cockatiel]

Asri Bey çok teşekkürederim.Yine sayenizde iş gücüm azaldı.Daha önceden de excel için özel işlemleri almıştım.Çoğu excel işimi fazlasıyla görüyor.Tekrardan teşekkürler.

 

[Asri]

Asri Bey çok teşekkürederim.Yine sayenizde iş gücüm azaldı.Daha önceden de excel için özel işlemleri almıştım.Çoğu excel işimi fazlasıyla görüyor.Tekrardan teşekkürler.

Tesadüf olmuş
Kolay gelsin.