Maybe:

Sub cramnij()
Dim x As Range
Dim y As String
Dim z As String
Dim i As Long
Dim w As Long
Dim ws As Worksheet
Dim ws2 As Worksheet
Set ws2 = Sheets("sheet2")
Set ws = Sheets("sheet1")
i = ws.Range("A" & Rows.Count).End(3).Row
y = ""
z = ""
With ws2
    For w = 2 To ws2.Range("A" & Rows.Count).End(3).Row
Set x = ws.Columns(1).Find(.Cells(w, "A").Value, LookIn:=xlValues, Lookat:=xlWhole)
    If Not x Is Nothing Then
    ws.Activate
    Cells(x.Row, x.Column).Select
    If ActiveCell.Offset(1).Value <> "" And ActiveCell.Row <= i Then
        .Cells(w, "A").Offset(, 1).Value = ActiveCell.Offset(, 2)
    End If
    If ActiveCell.Offset(1).Value = "" Then
            y = ActiveCell.Offset(, 2).Value
            z = y & ", "
            ActiveCell.Offset(1).Select
        Do Until ActiveCell.Value <> "" Or ActiveCell.Row + 1 > i
            y = ActiveCell.Offset(, 2).Value
            z = z & y & ", "
            z = z
            ActiveCell.Offset(1).Select
        Loop
        .Cells(w, "A").Offset(, 1).Value = z
        Set x = Nothing
    End If
    End If
Next w
End With
ws2.Activate
For Each x In Range("B2:B" & Range("B" & Rows.Count).End(3).Row)
    If Right(x, 2) = ", " Then x.Value = Left(x, Len(x) - 2)
Next x
End Sub