Aynı sütunu birleştirip verileri yanyana dizmek

Katılım
4 Aralık 2018
Mesajlar
3
Excel Vers. ve Dili
2007
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
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Makro ile yapmak isterseniz;

Kod:
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
 
Katılım
4 Aralık 2018
Mesajlar
3
Excel Vers. ve Dili
2007
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 (y)
 

Ali

Uzman
Katılım
21 Temmuz 2005
Mesajlar
7,893
Excel Vers. ve Dili
İş:Excel 2016-Türkçe
Alternatif

Kod:
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

Uzman
Katılım
21 Temmuz 2005
Mesajlar
7,893
Excel Vers. ve Dili
İş:Excel 2016-Türkçe
Formülle çözüm ise

D2 hücresine

Kod:
=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

Kod:
=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.
 
Katılım
12 Mart 2011
Mesajlar
1
Excel Vers. ve Dili
ms office2010
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
 
Üst