Sub uuu()
     With Sheets("Лист1")
         a = .Range("A2", Cells(Rows.Count, 2).End(xlUp)).Value
     End With
     Set sd = CreateObject("Scripting.Dictionary")
     For i = 1 To UBound(a)
         sd.Item(a(i, 2)) = sd.Item(a(i, 2)) & "|" & a(i, 1)
     Next
     With Sheets("Лист3")
         rw = 1
         For Each key_ In sd.Keys
             .Cells(rw, 1) = "Код " & key_
             rw = rw + 1
             sp = Split(sd.Item(key_), "|")
             For Each item_ In sp
                 If item_ <> "" Then
                     .Cells(rw, 1) = item_
                     rw = rw + 1
                 End If
             Next
             rw = rw + 1
         Next
     End With
End Sub