Sub iArticul()
Dim i As Long
Dim n As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundCell As Range
Dim FAdr As String
Application.ScreenUpdating = False
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
With Worksheets("Лист2")
   .Cells.ClearContents
   Range("A1:A" & iLastRow).AdvancedFilter xlFilterCopy, , .Range("A1"), True
   iLR = .Cells(.Rows.Count, "A").End(xlUp).Row
  For i = 2 To iLR
    n = 0
    Set FoundCell = Columns(1).Find(.Cells(i, "A"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      Do
       .Cells(i, 2 + n) = Cells(FoundCell.Row, "B")
       Set FoundCell = Columns(1).FindNext(FoundCell)
       n = n + 1
      Loop While FoundCell.Address <> FAdr
     End If
  Next
End With
Application.ScreenUpdating = True
End Sub