alt alta olan veriyi yan yana birleştirerek yazdırma

[husem]

merhaba arkadaşlar kolay gelsin.
excelde ortalama 5000 civarında satırım var. alt alta olan verileri de birliştirmem gerekiyor. aşağıdaki örnek veriler.
örnek veriye göre bana yardımcı olabilir misiniz?
yardımalrınız için şimdiden teşekkürn ederim.

örnek: a sütunu 1 nolu parti, b sütununda da kullanılan malzeme var. malzemeler alt alta yazılı

parti-----kullanılan malzeme
1=====> kalem
1=====> silgi
1=====> defter
2=====> cetvel
2=====> kalem
3=====> boya kalemi
4=====> kalem
5=====>tükenmez kalem
5=====> pastel boya

benim yapmak istediğim:
1=====> kalem, silgi, defter
2=====> cetvel, kalem
3=====> boya kalemi
4=====> kalem
5=====> tükenmez kalem, pastel boya

 

[volki_112]

merhaba arkadaşlar kolay gelsin.
excelde ortalama 5000 civarında satırım var. alt alta olan verileri de birliştirmem gerekiyor. aşağıdaki örnek veriler.
örnek veriye göre bana yardımcı olabilir misiniz?
yardımalrınız için şimdiden teşekkürn ederim.

örnek: a sütunu 1 nolu parti, b sütununda da kullanılan malzeme var. malzemeler alt alta yazılı

parti-----kullanılan malzeme
1=====> kalem
1=====> silgi
1=====> defter
2=====> cetvel
2=====> kalem
3=====> boya kalemi
4=====> kalem
5=====>tükenmez kalem
5=====> pastel boya

benim yapmak istediğim:
1=====> kalem, silgi, defter
2=====> cetvel, kalem
3=====> boya kalemi
4=====> kalem
5=====> tükenmez kalem, pastel boya

Alttaki kod istediğiniz şekilde verileri C sutununa yazar

Sub MalzemeleriBirlestir()

    Dim ws As Worksheet
    Dim sonSatir As Long
    Dim i As Long
    Dim dict As Object

    Set ws = ActiveSheet
    sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Set dict = CreateObject("Scripting.Dictionary")

    'Verileri sözlüğe aktar
    For i = 2 To sonSatir 'Başlık varsa 2. satırdan başlıyoruz
        If ws.Cells(i, "A").Value <> "" Then
            If Not dict.exists(ws.Cells(i, "A").Value) Then
                dict.Add ws.Cells(i, "A").Value, ws.Cells(i, "B").Value
            Else
                dict(ws.Cells(i, "A").Value) = dict(ws.Cells(i, "A").Value) & ", " & ws.Cells(i, "B").Value
            End If
        End If
    Next i

    'Sonuçları C sütununa yaz
    For i = 2 To sonSatir
        If ws.Cells(i, "A").Value <> "" Then
            ws.Cells(i, "C").Value = ws.Cells(i, "A").Value & " => " & dict(ws.Cells(i, "A").Value)
        End If
    Next i
End Sub

 

[husem]

Sayın volki_112; yardımın için çok teşekkür ederim, sayenizde tamamlandı.

 

[Mdemir63]

Selam
Alternatif olsun

Sub PartiGrupla()
    Dim dict As Object
    Dim i As Long, sonSatir As Long
    Dim parti As Variant, malzeme As String
    Dim ws As Worksheet
    
    Set ws = ThisWorkbook.Sheets("Sayfa1")
    Set dict = CreateObject("Scripting.Dictionary")
    sonSatir = ws.Cells(Rows.Count, "A").End(xlUp).Row

    For i = 2 To sonSatir
        parti = ws.Cells(i, 1).Value
        malzeme = ws.Cells(i, 2).Value
        If dict.exists(parti) Then
            dict(parti) = dict(parti) & ", " & malzeme
        Else
            dict.Add parti, malzeme
        End If
    Next i

    ws.Range("C1").Value = "Parti => Malzeme Listesi"
    i = 2
    For Each parti In dict.Keys
        ws.Cells(i, 3).Value = parti & " => " & dict(parti)
        i = i + 1
    Next parti
End Sub

 

[Korhan Ayhan]

Merhaba,

Özet tablo ile alternatif...

Pivot tabloda değer kısmına metin yazdırma...

Merhabalar, konuyla ilgili olarak ekte paylaştığım dosyada da gözüktüğü üzere en soldaki gibi bir tablo/verilerim için pivot tablo yaptığım zaman ortadaki gibi olmakta lakin ben en sağdaki manuel olarak hazırladığım şekilde olmasını istiyorum. herhangi bir yöntem, formül vs. var mıdır bilen...

www.excel.web.tr