Concatenate cellls where duplicates exist

Sub test()
Dim r As Range, filt As Range, dest As Range, ra As Range, cdest As Range
Dim part As String, y As String, j As Integer, k As Integer
Worksheets("sheet1").Activate
Range(Range("a1").End(xlDown).Offset(1, 0), Cells(Rows.Count, "A")).EntireRow.Delete

Set r = Range("A1").CurrentRegion
Set dest = Range("A1").End(xlDown).Offset(5, 0)
Set ra = Range(Range("a1"), Range("a1").End(xlDown))
r.Sort key1:=Range("a1"), header:=xlYes

ra.AdvancedFilter xlFilterCopy, , dest, True
Set dest = Range(dest.Offset(1, 0), dest.End(xlDown))
For Each cdest In dest
part = cdest.Value
r.AutoFilter field:=1, Criteria1:=part
Set filt = r.Offset(1, 0).Resize(r.Rows.Count - 1).SpecialCells(12)

j = WorksheetFunction.CountA(filt.Areas(1).Columns("B:B"))

'msgbox j

For k = 1 To j
y = y & "," & filt.Areas(1).Cells(k, 2)
Next k
'msgbox y
y = Right(y, Len(y) - 1)
'msgbox y
cdest.Offset(0, 1) = y
ActiveSheet.AutoFilterMode = False
y = ""
Next cdest

End Sub