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

Option Explicit
Dim dic As Object

Sub main()
    Dim arr, sArt$, s$
    Dim lr&, lc&, llastc&, llastr&
    Set dic = CreateObject("scripting.dictionary")
    dic.comparemode = 1
    
    With ActiveSheet
        sArt = .Range("H3").Value
        If Len(sArt) = 0 Then Exit Sub
        
        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
        .Range("H4").Resize(dic.Count, 1).Value = Application.Transpose(dic.keys)
    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

Sub Get_All_File_from_Folder()
    Dim sFolder As String, sFiles As String
    Dim wb As Workbook
    Dim rres As Range
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
    Application.ScreenUpdating = False
    Set rres = ActiveSheet.Range("B1")
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        'открываем книгу
        Set wb = Application.Workbooks.Open(sFolder & sFiles)
        'действия с файлом
        'Запишем на первый лист книги в ячейку А1 - www.excel-vba.ru
        rres.Offset(1).Value = wb.Sheets(1).Range("F13").Value
        'Закрываем книгу с сохранением изменений
        wb.Close True 'если поставить False - книга будет закрыта без сохранения
        Set rres = rres.Offset(1)
        sFiles = Dir
    Loop
    'возвращаем ранее отключенное обновление экрана
    Application.ScreenUpdating = True
End Sub

If MHC.Value = False And inzh.Value = False And Mail.SendTo.Value = "" Then
If Mail.SendTo.Value = "" Then
MsgBox "Пусто"
Else
MsgBox Mail.SendTo.Value
End If
End If

If MHC.Value = False And inzh.Value = False And Mail.SendTo.Value = "" Then
If Mail.SendTo.Value = "" Then
MsgBox "Пусто"
Else
MsgBox Mail.SendTo.Value
End If
Exit Sub
End If