Sub Kod_Naimenov()
Dim iLastRow As Long
Dim i As Long
Dim Kod As String
Dim FoundKod As Range
Dim FirstAdres As String
Dim Naimenov As String
  iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range("E4:E" & iLastRow).ClearContents
  For i = 4 To iLastRow
    Kod = Cells(i, "B")
Set FoundKod = Columns(2).Find(Kod, Cells(i, "B"), xlValues, xlWhole)
    If Not FoundKod Is Nothing Then     'нашли код
        FirstAdres = FoundKod.Address   'адрес первого вхождения
          If FoundKod.Row = i Then
            Naimenov = Cells(FoundKod.Row, "C")
          End If
        Do
            Cells(i, "E") = Cells(i, "E") & FoundKod.Offset(, -1) & ", "
          Set FoundKod = Columns(2).FindNext(FoundKod)
        Loop While FoundKod.Address <> FirstAdres
          Cells(i, "E") = Left(Cells(i, "E"), Len(Cells(i, "E")) - 2)
    End If
  Next
End Sub