Option Explicit

Sub Perebor() 'коллекция в словаре
    Dim a, i&, ii&, x&, t$, D1 As Object, D2 As Object
    Dim outdoc, outart
    
    a = Range("D8", Cells(Rows.Count, "A").End(xlUp)).Value
    Set D1 = CreateObject("Scripting.Dictionary")
    Set D2 = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            t = a(i, 3)
            If Not D1.exists(t) Then D1.Add t, New Collection
            D1.Item(t).Add a(i, 1)
            t = a(i, 1)
            If Not D2.exists(t) Then D2.Add t, New Collection
            D2.Item(t).Add a(i, 3) & "|" & a(i, 4)
        Next

    
Set outdoc = D1.Item("2081") 'тут доработать ввод нужного артикула - можно брать с листа, или в запросе пользователя
[h1].CurrentRegion.Clear
For i = 1 To outdoc.Count
    Set outart = D2.Item(outdoc(i))
    For ii = 1 To outart.Count
        x = x + 1
        Cells(x, 8).Resize(, 2) = Split(outart(ii), "|")
        Cells(x, 10) = "'" & outdoc(i)
    Next
Next

End Sub