Sub Articul()
Dim i As Long
Dim k As Long
Dim iLastRow As Long
Dim FoundArticul As Range
Dim FAdr As String
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
 Range("H1:M" & iLastRow).ClearContents
 Range("A1:A" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("H1"), Unique:=True
 iLastRow = Cells(Rows.Count, "H").End(xlUp).Row
      For i = 2 To iLastRow
        Set FoundArticul = Columns(1).Find(Cells(i, "H"), , xlValues, xlWhole)
         If Not FoundArticul Is Nothing Then
            FAdr = FoundArticul.Address
            k = 1
          Do
           Cells(i, 8 + k) = Cells(FoundArticul.Row, "C")
           k = k + 1
           Set FoundArticul = Columns(1).FindNext(FoundArticul)
          Loop While FoundArticul.Address <> FAdr
         End If
      Next
End Sub