Sub PoiskArtikul()
Dim Rg1 As Range, ImList$, Arr1, i&, j&, kSt%, Tp1, Tp2, Kluh$, CelVst$, Poisk$
Dim Sh As Worksheet, Dic1 As New Collection
CelVst = "АРТИКУЛ": ImList = "Основной"

Do
Poisk = InputBox("", "Введите АРТИКУЛ", "22009876")
    If StrPtr(Poisk) = 0 Then Exit Sub ' Выход из процедуры при нажатии кнопки Cancel
Loop Until Poisk <> vbNullString

Application.ScreenUpdating = False
Set Rg1 = ThisWorkbook.Worksheets(ImList).Cells
For Each Sh In ThisWorkbook.Worksheets
    If VBA.StrComp(Sh.Name, ImList, 1) <> 0 Then
    Arr1 = Sh.Cells(1).CurrentRegion.Value
    If Not VBA.IsArray(Arr1) Then GoTo Ex
    kSt = UBound(Arr1, 2)
    ReDim Tp1(1 To kSt)
        For i = 2 To UBound(Arr1)
            If Arr1(i, 1) = Poisk Then
                For j = 1 To kSt
                Tp1(j) = Arr1(i, j)
                Next j
            Kluh = VBA.Join(Tp1, vbNullChar)
            If Not Exists(Dic1, Kluh) Then Dic1.Add Kluh, Kluh
            End If
        Next i
    End If
Ex:
Next Sh
If Dic1.Count = 0 Then MsgBox CelVst & " " & Poisk & " не найден", vbCritical: Exit Sub

Set Rg1 = Rg1.Find(CelVst, , xlValues, xlWhole, xlByRows)
If Rg1 Is Nothing Then MsgBox "На листе " & ImList & _
" не найдена ячейка для вставки со значением " & CelVst: Exit Sub
ReDim Arr1(kSt - 1, 1 To Dic1.Count): i = 0
For Each Tp1 In Dic1
    i = i + 1
    Tp2 = VBA.Split(Tp1, vbNullChar)
    For j = 0 To UBound(Tp2)
    Arr1(j, i) = Tp2(j)
Next j, Tp1

    With Rg1(, 2).Resize(UBound(Arr1) + 1, UBound(Arr1, 2))
        .Value = Arr1
        .EntireColumn.AutoFit
    End With
End Sub
Private Function Exists(coll As Collection, key$) As Boolean
On Error GoTo EH
coll.Item key: Exists = True
EH:
End Function 'Функция для проверки наличия ключа коллекции

Tp2 = col(col.Count)

Set Rg1 = ThisWorkbook.Worksheets(ImList).Cells

Set Rg1 = ThisWorkbook.Worksheets(ImList).UsedRange