Sub Кнопка1_Щелчок()
UserForm1.Show
End Sub

Sub Кнопка1_Щелчок()
UserForm1.Show
End Sub
'вызов формы поиска
Sub CallFind()
ufFind.Show
End Sub

Sub S4itivanie() 'Макрос2 - копирование из книги
    Dim ImaKnig1 As Workbook
    Dim ImaKnig3 As String, ImaKnig2
    Dim IsNeedClose As Boolean
    
    Set ImaKnig1 = ThisWorkbook
    ImaKnig2 = Application.GetOpenFilename _
                    ("Excel files(*.xls*),*.xls*", 1, "Выбрать Excel файлы для передачи данных", , False)
    If VarType(ImaKnig2) = vbBoolean Then
        Exit Sub
    End If
    
    ImaKnig3 = Dir(ImaKnig2)
    If ImaKnig3 <> "" Then 'проверяем, что эта книга есть по этому пути
        Application.EnableEvents = False
        If Not BookOpenClosed((ImaKnig3)) Then
            IsNeedClose = True 'флаг, что книгу надо закрыть
            Application.Workbooks.Open ImaKnig2
        End If
        Application.Workbooks(ImaKnig3).Worksheets("Спецификация").Range("A2:J23").Copy ImaKnig1.Sheets("Спецификация").Range("A2")
        If IsNeedClose Then
            Application.Workbooks(ImaKnig3).Close False
        End If
        Application.EnableEvents = True
    End If
End Sub
 
'функция, предназначенная для проверки, открыта или закрыта рабочая книга.
Function BookOpenClosed(wbName As String) As Boolean
    Dim myBook As Workbook
    On Error Resume Next
        Set myBook = Workbooks(wbName)
    BookOpenClosed = Not myBook Is Nothing
End Function

Dim ВыкладкаФайлы
ВыкладкаФайлы = Selection.Value2
If Not IsArray(ВыкладкаФайлы) Then
    ReDim ВыкладкаФайлы(1 to 1, 1 to 1)
    ВыкладкаФайлы(1,1) = Selection.Value2
end if

=ВЫЧИСЛИТЬ(Лист1!A1)

Function EvalCell(rc As Range)
    EvalCell = Evaluate(rc.Value)
End Function

Dim dic As Object

Sub main()
    Dim arr, aarts, sArt$, s$
    Dim lr&, lc&, la&, llastc&, llastr&
    
    
    With ActiveSheet
        llastc = .Cells(3, .Columns.Count).End(xlToLeft).Column
        aarts = .Cells(3, 8).Resize(2, llastc - 7).Value
        For la = 1 To UBound(aarts, 2)
            sArt = aarts(1, la)
            Set dic = CreateObject("scripting.dictionary")
            dic.comparemode = 1
            If Len(sArt) Then
                dic.Add sArt, 0&
                llastr = .Cells(.Rows.Count, 1).End(xlUp).Row
                llastc = 4
                arr = .Cells(3, 1).Resize(llastr - 2, llastc).Value
            
                For lr = 1 To UBound(arr, 1)
                    s = arr(lr, 1)
                    If s = sArt Then
                        For lc = 2 To UBound(arr, 2)
                            s = arr(lr, lc)
                            If Len(s) Then
                                If Not dic.exists(s) Then
                                    dic.Add s, 0&
                                    GetLinkedArt s, arr
                                End If
                            End If
                        Next
                        Exit For
                    End If
                Next
                dic.Remove sArt
                If dic.Count > 0 Then
                    .Cells(4, la + 7).Resize(dic.Count, 1).Value = Application.Transpose(dic.keys)
                End If
            End If
        Next
    End With
End Sub
Function GetLinkedArt(sArt$, arr)
    Dim lr&, lc&, s$
    For lr = 1 To UBound(arr, 1)
        s = arr(lr, 1)
        If s = sArt Then
            For lc = 2 To UBound(arr, 2)
                s = arr(lr, lc)
                If Len(s) Then
                    If Not dic.exists(s) Then
                        dic.Add s, 0&
                        GetLinkedArt s, arr
                    End If
                End If
            Next
            Exit For
        End If
    Next
End Function