sütundaki verileri, bir değişkene göre virgül ile ayrılmış olarak yazdırmak

[ocannn]

Merhaba arkadaşlar,
Ekteki örnek dosyaya benzer ve daha uzun bir çalışma sayfam var. Bu çalışma sayfasında "B" sütunundaki veri değişene kadar "A" sütunundaki verileri "B" sütununun ilk değişkeninin yanındaki hücreye virgül ile ayrılmış olarak yazdırmak istiyorum. Veri çok olduğu için klasik "seçimi tersine çevir" gibi yöntemler ile yapmak vakit kaybı ve hata yapma olasılığı yüksek, dolayısıyla makro gerekiyor. Yardımcı olursanız sevinirim.
(Ekteki örnek sayfa 1 veriyi, sayfa 2 ise işlem bittiğinde ulaşmayı hedeflediğim listeyi göstermektedir.)

 

[Muzaffer Ali]

Dosyanız ekte

 

[ocannn]

Teşekkür ederim, ancak sıra noların değişmemesi gerekiyor. yani virgül ile yazdırılacak verilerin ana listedeki aynı sıra no'nun hizasında olmasına ihtiyacım var. Çünkü bu sora nolar başka bir listedeki grup noları ile aynı. Daha sonra bunları eşleştireceğim. Hazırlamış olduğunuz kodda sıra no 1 iki defa tekrar ediyor ve 251 olan grup(sıra no) 250 olarak sona eriyor. Sorunu daha iyi anlatabilmişimdir umarım.

 

[Orion1]

Dosyanız ektedir.

Sub tekrarsiz59()
Dim liste(), i As Long, sat As Long, z As Object
Sheets("Sayfa1").Select
sat = Cells(Rows.Count, "A").End(xlUp).Row
liste = Range("A2:B" & sat).Value
Set z = CreateObject("scripting.dictionary")
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 2)) Then
        z.Add (liste(i, 2)), CStr("'" & liste(i, 1))
        Else
        z.Item(liste(i, 2)) = CStr(z.Item(liste(i, 2)) & "," & CStr(liste(i, 1)))
    End If
Next i
Erase liste
Sheets("Sayfa2").Select
Range("A2:B" & sat).ClearContents
Range("A2").Resize(z.Count, 2) = Application.Transpose(Array(z.keys, z.items))
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com", _
        vbOKOnly + vbInformation, Application.UserName
End Sub

 

[ocannn]

Teşekkürler elinize sağlık.