virgül koyarak birleştirme

[omerfe]

ekteki gibi bir tablom var ve bu tabloda ortak değere göre birleştirme yapmam gerekiyor. Veriyi ve isteneni göstermeye çalıştım excel dosyasında alt alta.

A sütunu ortak değer.. D sütunundaki ve E sütunundaki verileri aralarına virgül koyarak birleştirmeye çalışıyorum.

Yardımlarınız için teşekkürler.

 

[YUSUF44]

Sonuç kısmı yani istenen kısmı bu şekilde önceki halinin altında mı olacak, başka yerde mi olacak?

 

[muygun]

Merhaba;
Veri miktarının değişken olacağını varsayarak sonuç tablosunu sağ tarafa aldım.
İnceleyin.
İyi çalışmalar.

 

[omerfe]

yusuf44, muygun çok teşekkürler. muygun'un eklediği dosya ile istediğim sonuca ulaşabildim. emeğinize sağlık..

Allah işinizi gücünüzü rast getirsin.

 

[Korhan Ayhan]

Alternatif olarak deneyiniz.

Daha iyi performans alabilirsiniz.

Sub Makro()
    Application.ScreenUpdating = False
    Range("G3:K" & Rows.Count).Clear
    Son_Satir = Cells(Rows.Count, 1).End(3).Row
    Satir = 3

    For X = 3 To Son_Satir
        Range("G" & Satir & ":I" & Satir).Value = Range("A" & X & ":C" & X).Value
        Ilk = X
        Son = X - 1 + WorksheetFunction.CountIf(Range("A:A"), Cells(X, 1))
        Cells(Satir, "J") = Join(Application.Transpose(Range("D" & Ilk & ":D" & Son)), ",")
        Cells(Satir, "K") = Join(Application.Transpose(Range("E" & Ilk & ":E" & Son)), ",")
        Satir = Satir + 1
        X = Son
    Next
    
    Cells.VerticalAlignment = xlCenter
    Range("J3:K" & Satir - 1).WrapText = True
    Range("G3:K" & Satir - 1).Borders.LineStyle = 1
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[omerfe]

Alternatif olarak deneyiniz.

Daha iyi performans alabilirsiniz.

Sub Makro()
    Application.ScreenUpdating = False
    Range("G3:K" & Rows.Count).Clear
    Son_Satir = Cells(Rows.Count, 1).End(3).Row
    Satir = 3

    For X = 3 To Son_Satir
        Range("G" & Satir & ":I" & Satir).Value = Range("A" & X & ":C" & X).Value
        Ilk = X
        Son = X - 1 + WorksheetFunction.CountIf(Range("A:A"), Cells(X, 1))
        Cells(Satir, "J") = Join(Application.Transpose(Range("D" & Ilk & ":D" & Son)), ",")
        Cells(Satir, "K") = Join(Application.Transpose(Range("E" & Ilk & ":E" & Son)), ",")
        Satir = Satir + 1
        X = Son
    Next
    
    Cells.VerticalAlignment = xlCenter
    Range("J3:K" & Satir - 1).WrapText = True
    Range("G3:K" & Satir - 1).Borders.LineStyle = 1
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

korhan hocam teşekkürler. sizden bir ricam olacak..

daha önce ömer hocamın yardımcı olduğu bir sorum vardı aşağıda linkte.. yukarıda cevapladığınız sorumun cevabını aşağıdaki linkte bulunan makronun içine yerleştirebilir miyiz? aşağıdaki linkte nasıl bir sonuca ulaşmak istediğimden bahsetmiştim 22-10-2015, 12:11 tarihli mesajımda..

http://www.excel.web.tr/f14/ortak-deoere-gore-birle-tirme-t150332.html#post828052