Aynı sütunu birleştirip verileri yanyana dizmek

[ratm]

Aslında buraya başlık açmak istemezdim ama google da bu konuyu nasıl arayacağımı bile bilemedim, ne türkçe ne ingilizce. Aslında yapmak istediğim şey çok basit gibi görünüyor ama bir türlü basit bir çözüm bulamadım. Yardımcı olursanız sevinirim.

Bir sütundaki aynı verileri içeren satırları birleştiriyor ve o sütunun yanındaki sütunda bulunan verileri yanyana olacak şekilde birleştirilen verinin yanına yazıyoruz.
Zaten aşağıdaki resimlerden kolayca anlaşılır.

Şu haldeki verileri

Şu hale getirmek istiyorum :

Yardımcı olabilir misiniz

 

[turist]

Sayın @ratm
Forumumuza hoş geldiniz.
Aşağıdaki Linkte bulunan Örnek dosyayı indirip inceleyiniz.
Dosyanızın Linki

 

[ratm]

Sayın @ratm
Forumumuza hoş geldiniz.
Aşağıdaki Linkte bulunan Örnek dosyayı indirip inceleyiniz.
Dosyanızın Linki

Cevap için çok teşekkürler, hemen uyguluyorum

 

[veyselemre]

Makro ile yapmak isterseniz;

Sub satirlardakiVerileriSutunlaraAktar()

    Set dic = CreateObject("Scripting.Dictionary")
    veriler = Range("a1:B" & Cells(Rows.Count, 1).End(3).Row).Value

    With dic
        For i = 1 To UBound(veriler)
            anahtar = veriler(i, 1)
            veri = veriler(i, 2)
            If Not .exists(anahtar) Then
                .Add anahtar, anahtar & "|" & veri & "|"
            Else
                .Item(anahtar) = .Item(anahtar) & veri & "|"
            End If
        Next i
        liste = .items
    End With

    Range("$D$1:" & Cells(Rows.Count, Columns.Count).Address).ClearContents

    Set Rng = Range("D1")

    For Each lst In liste
        ver = Split(Left(lst, Len(lst) - 1), "|")
        Rng.Resize(, UBound(ver) + 1).Value = ver
        Set Rng = Rng.Offset(1)
    Next

    Set dic = Nothing
    Set Rng = Nothing

End Sub

 

[ratm]

Bu çok iyi oldu hocam. Excel e çok hakim olmadığım için Macro ile daha kolay oldu. Çalıştır dedim zaten iş bitti

 

[Ali]

Alternatif

Sub sırala()
Dim d As Object, u(), c()
Dim a, e, ra As Long, i As Long
Set d = CreateObject("scripting.dictionary")
a = Range("A1").CurrentRegion
ra = UBound(a, 1)
ReDim u(1 To ra, 1 To 2), c(1 To ra + 1)
For i = 1 To ra
    e = a(i, 1)
    If Not d.exists(e) Then
        d(e) = d.Count + 1
        u(d(e), 1) = e
        u(d(e), 2) = a(i, 2)
        c(d(e)) = 2
    Else
        c(d(e)) = c(d(e)) + 1
        If c(d(e)) > UBound(u, 2) Then _
            ReDim Preserve u(1 To ra, 1 To c(d(e)))
        u(d(e), c(d(e))) = a(i, 2)
    End If
Next i
Cells(2, 4).Resize(d.Count, UBound(u, 2)) = u
End Sub

 

[Ali]

Formülle çözüm ise

D2 hücresine

=EĞERHATA(İNDİS($A$2:$A$20;KÜÇÜK(EĞER(SIKLIK(EĞER($A$2:$A$20<>"";KAÇINCI($A$2:$A$20;$A$2:$A$20;0));SATIR($A$2:$A$20)-SATIR($A$2)+1);SATIR($A$2:$A$20)-SATIR($A$2)+1);SATIRSAY($D$2:$D2)));"")

yazıp CTRL+SHIFT+ENTER tuşlarına basarak dizi formülü oluşturup aşağı doğru çekiniz.

E2 hücresine de

=EĞER(D2="";"";EĞERHATA(İNDİS($B$2:$B$20;KÜÇÜK(EĞER($A$2:$A$20=$D2;SATIR($A$2:$A$20)-SATIR($A$2)+1);SÜTUNSAY($E2:E2)));""))

yazıp CTRL+SHIFT+ENTER tuşlarına basarak dizi formülü oluşturup sağa ve aşağı doğru çekerek doldurunuz.

 

[mutlukilyar]

merhaba
yukarıdaki ilk makro çalışıyor
ancak benim çalıştığım veri biraz fazla
sütunda 225.000 veri var 160 değişik ürün var
375 sütun yazıyor kalanını yazmıyor
bana yaklaşık 1500 sütun lazım
ne yapmalıyım
teşekkürler