DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
[FONT="Arial Narrow"][B][COLOR="Blue"]Sub birlestir_BRN()[/COLOR][/B]
Range("C:D").ClearContents
Cells(1, 3) = Cells(1, 1): Cells(1, 4) = Cells(1, 2)
For satır = 2 To [A65536].End(3).Row
adet = WorksheetFunction.CountIf(Range("A:A"), Cells(satır, 1))
metin = ""
For sat = satır To satır + adet - 1
metin = metin & Cells(sat, 2) & Chr(10)
Next
Cells([C65536].End(3).Row + 1, 3) = Cells(satır + adet - 1, 1)
Cells([D65536].End(3).Row + 1, 4) = Left(metin, Len(metin) - 1)
satır = satır + adet - 1
Next
Range("C:D").VerticalAlignment = xlCenter
[B][COLOR="blue"]End Sub[/COLOR][/B][/FONT]
Elinize kolunuza sağlık 10 numara tam istediğim gibi
Saygı ve sevgiler emeği geçen herkese
Sub DerleTopla()
Dim d
Dim i As Long
Dim s
Dim Deg As Variant
Dim a1
Dim a2
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To Cells(Rows.Count, "A").End(3).Row
Deg = Cells(i, "A")
If Not d.exists(Deg) Then
s = Cells(i, "B")
d.Add Deg, s
Else
s = d.Item(Deg)
s = s & Chr(10) & Cells(i, "b")
d.Item(Deg) = s
End If
Next i
a1 = d.keys
a2 = d.items
Range("E1").Resize(d.Count, 1) = Application.Transpose(a1)
Range("F1").Resize(d.Count, 1) = Application.Transpose(a2)
End Sub