Aynı olanları sıralama

[NADİR YILDIZ]

Arkadaşlar kolay gelsin mal cinsleri ve isimlere göre listem var bu listede aynı mal cinsine ait isimleri aralarında virgül olacak şekilde fonksiyonla nasıl yanyana sıralatabilirim

 

[savas_145]

her hücreye bir isim gelecek şekilde sıralatabilirim ama aynı hücrede virgülle ayırma olayı formülle çok sıkıntılı olur. birleştir fonksiyonuyla yapabilirsiniz belki ama oda elinizdeki dosya bu kadar kısa olmayacağını düşündüğümden ve bir ürüne ait max kaç isim olacak onun değişken olacağını düşündüğümden zor gibi.
yani formülden ziyade makrolu bir çözüm aramalısınız.

 

[tahsinanarat]

Sub aktar()
Sheets("Sayfa2").Range("A2:d65000").ClearContents
sat = 1
For r = 1 To Worksheets("Sayfa1").[a65536].End(3).Row
aranan1 = Sheets("Sayfa1").Cells(r, 1).Value
say1 = ""
If Sheets("Sayfa1").Cells(r, 2).Value <> "" Then
If WorksheetFunction.CountIf(Worksheets("Sayfa1").Range("a1:a" & r), aranan1) = 1 Then
For i = r To Worksheets("Sayfa1").[a65536].End(3).Row
aranan2 = Sheets("Sayfa1").Cells(i, 1).Value
If aranan2 = aranan1 Then
If say1 = "" Then
ekle = ""
Else
ekle = " , "
End If
say1 = say1 & ekle & Sheets("Sayfa1").Cells(i, 3).Value & Sheets("Sayfa1").Cells(i, 2).Value
End If
Next i
Sheets("Sayfa2").Cells(sat, 1).Value = Sheets("Sayfa1").Cells(r, 1).Value
'Sheets("Sayfa2").Cells(sat, 2).Value = Sheets("Sayfa1").Cells(r, 4).Value
Sheets("Sayfa2").Cells(sat, 2).Value = say1
sat = sat + 1
End If
End If
Next r
'MsgBox "işlem tamam"
End Sub

 

[NADİR YILDIZ]

Teşekkür ederim tahsin bey