iki sütundaki satırları birleştirmek

[osmanoca]

merhaba değerli dostlar. acil yardım lazım.

bir sözlük excel dosyam var. ilk sütundaki bazı kelimeler aynı. anlamları olan B sütunundan farklı anlamlar var. mesela 5 aynı kelime varken anlam sütununda toplamda 5 farklı anlam var. aynı kelimeleri tek satır yapıp farklı anlamları bir satırda çok anlamlı olarak birleştirmek istiyorum.

örnek:
Example:
A B
Abadîn Ölmez
Abadîn Bengi
Abadîn Ebedî
Abadîn Kalıcı

bunların şöyle tek satırda virgüllü olmasını istiyorum:
Example:
A.................................B
Abadîn.........................Ölmez,Bengi,Ebedî,Kalıcı

macro olursa iyi olur. diğerlerini yapmayı tam bilmiyorum. çooook teşekkür şimdiden. çok acil lazım.

 

[Asri]

Aşağıdaki kodu kullanabilirsiniz. İşlem tamamlandıktan sonra C kolonuna göre sıralama yaptırın.

Sub anlam_birlestir()
   Application.ScreenUpdating = False
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   yenianlam = ""
   ilksatir = 1
   For i = 1 To sonsatir + 1
    kelime = Cells(i, "A").Value
    anlam = Cells(i, "B").Value
    
    If kelime = eskikelime Or i = 1 Then
       yenianlam = yenianlam & anlam & ","
    Else
       Cells(ilksatir, "C").Value = Mid(yenianlam, 1, Len(yenianlam) - 1)
       ilksatir = i
       yenianlam = ""
       yenianlam = yenianlam & anlam & ","
    End If
    eskikelime = kelime
   Next i
   Application.ScreenUpdating = True
End Sub

 

[osmanoca]

çalıştı ama tekrarları silmedi

kod çalıştı ikinci sütundaki kelimeleri birleştirdi ama ilk sütundaki tekrarları silmedi. A sütununda sadece bir tanesinin kalması lazım. anlamların onun karşısında birleşmesi lazım. bu sözlük olacağı için. tekrarlardan biri kalacak, karşısında tüm anlamlar olacak.

Aşağıdaki kodu kullanabilirsiniz. İşlem tamamlandıktan sonra C kolonuna göre sıralama yaptırın.

Sub anlam_birlestir()
   Application.ScreenUpdating = False
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   yenianlam = ""
   ilksatir = 1
   For i = 1 To sonsatir + 1
    kelime = Cells(i, "A").Value
    anlam = Cells(i, "B").Value
    
    If kelime = eskikelime Or i = 1 Then
       yenianlam = yenianlam & anlam & ","
    Else
       Cells(ilksatir, "C").Value = Mid(yenianlam, 1, Len(yenianlam) - 1)
       ilksatir = i
       yenianlam = ""
       yenianlam = yenianlam & anlam & ","
    End If
    eskikelime = kelime
   Next i
   Application.ScreenUpdating = True
End Sub

 

[Asri]

kod çalıştı ikinci sütundaki kelimeleri birleştirdi ama ilk sütundaki tekrarları silmedi. A sütununda sadece bir tanesinin kalması lazım. anlamların onun karşısında birleşmesi lazım. bu sözlük olacağı için. tekrarlardan biri kalacak, karşısında tüm anlamlar olacak.

sonucu aldıktan sonra c ye göre sıralayın diye belirtmiştim. Tek satırlar alt alta gelecek.
sonra diğerlerini silersiniz.

 

[Korhan Ayhan]

Alternatif olarak deneyiniz.

Yeni liste C-D sütunlarına oluşur.

Option Explicit

Sub ANLAMLARI_BİRLEŞTİR()
    Dim Son As Long, X As Long, Kelime As Variant, Say As Long, Satir As Long
    
    Application.ScreenUpdating = False
    
    Son = Cells(Rows.Count, 1).End(3).Row
    Range("C:D").ClearContents
    Satir = 1
    
    For X = 1 To Son
        Kelime = Cells(X, 1).Value
        Say = WorksheetFunction.CountIf(Range("A:A"), Kelime)
        Select Case Say
            Case 1
                Cells(Satir, 3) = Kelime
                Cells(Satir, 4) = Cells(X, 2)
            Case Is > 1
                Cells(Satir, 3) = Kelime
                Cells(Satir, 4) = Join(Application.Transpose(Range(Cells(X, 2), Cells(X + Say - 1, 2))), ", ")
        End Select
        X = X + Say - 1
        Satir = Satir + 1
    Next
    
    Range("C:D").EntireColumn.AutoFit

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[osmanoca]

Asri ve Korhan Ayhan, Çok teşekkürler, dediğiniz gibi oldu.İstediğimi elde ettim. Çok sağolun...

Alternatif olarak deneyiniz.

Yeni liste C-D sütunlarına oluşur.

Option Explicit

Sub ANLAMLARI_BİRLEŞTİR()
    Dim Son As Long, X As Long, Kelime As Variant, Say As Long, Satir As Long
    
    Application.ScreenUpdating = False
    
    Son = Cells(Rows.Count, 1).End(3).Row
    Range("C:D").ClearContents
    Satir = 1
    
    For X = 1 To Son
        Kelime = Cells(X, 1).Value
        Say = WorksheetFunction.CountIf(Range("A:A"), Kelime)
        Select Case Say
            Case 1
                Cells(Satir, 3) = Kelime
                Cells(Satir, 4) = Cells(X, 2)
            Case Is > 1
                Cells(Satir, 3) = Kelime
                Cells(Satir, 4) = Join(Application.Transpose(Range(Cells(X, 2), Cells(X + Say - 1, 2))), ", ")
        End Select
        X = X + Say - 1
        Satir = Satir + 1
    Next
    
    Range("C:D").EntireColumn.AutoFit

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub