Sub Сбор_тестов()
'присваиваем переменной объект - первый лист, активной рабочей книги
Set shAct = ActiveWorkbook.Sheets(1)
'это словарь, этот словарь нужен что бы собрать данные об неотработанных файлах
'(если по такому пути файла не существует то файл будет не отработан)
Set dicFail = CreateObject("Scripting.Dictionary")
' в этот словарь будем складывать массивы arr где будут находиться данные построчно
Set dic = CreateObject("Scripting.Dictionary")
' путь к папке с подпапками
folder = [A1]
' имя файла из A2
fileTest = [A2]
' количество папок
qty = [A3]
' присваиваем переменной ячейку с которой будет начинаться вывод данных в таблицу
Set cellOut = [D5]
' номер колонки ячейки откуда начинается вывод данных
' понадобится для того что бы с верхних ячеек брать имя листа и ячейки
cc = cellOut.Column
' цикл с 1 до цифры-колчество папок. Те перебираем папки.
' q будет принимать значения с 1 и до qty
For q = 1 To qty
' в статус бар пишем номер обрабатываемой папки.
Application.StatusBar = q
     ' путь к файлу
     file_path = folder & "\" & q & "\" & fileTest
     ' если по такому пути файла не найдено, то будет переход к следующей папке
     If Dir(file_path) = "" Then dicFail.Item(q) = 0&: GoTo skipFolder
     ' в фотоном режиме открывается файл, он условно у нас будет называться wb
     Set wb = GetObject(file_path)
     ' в этот массив будем помещать данные (предыдущие данные по другому q будут затираться
     ReDim arr(0 To 7)
     'перебираем i с нуля и до верхней границы массива arr, здесь это 7
     For i = 0 To UBound(arr)
         ' имя листа с которого брать данные находится в ячейке главной таблицы,
         ' первая строка, колонка = колонка первой ячейки вывода (cellOut) + смещение = i
         shName = shAct.Cells(1, cc + i)
         ' то же самое только вторая строка
         cell = shAct.Cells(2, cc + i)
         ' в массив в нужную полочку i складываем значение из wb - файл который открыли в фоновом режиме
         ' Sheets(shName) - нужный лист, - Range(cell) нужная ячейка
         arr(i) = wb.Sheets(shName).Range(cell)
     Next
     ' в словарь для значения q  записываем то что насобирали в массив arr для этого q
     dic.Item(q) = arr
     ' закрываем без сохранения открытый в фоновом режиме файл
     wb.Close False
' это метка к которой придет процедура если путь к файлу не найден
skipFolder:
Next
' сбрасываем то что писали в статус баре
Application.StatusBar = False
' вывод данных. ячейку cellOut (D4) "расширяем" до нужных размеров.
' т.е. нам надо что бы начиная с ячейки cellOut таблица расширилась вниз
' на то количество сколько записей в словаре насобирали
' вбок таблица расширится на обрабатываемое количество столбцов здесь 8
' Application.Transpose(Application.Transpose(dic.items)) - не буду объяснять подробно
'  - так скопом можно вывести массивы из значений словаря
cellOut.Resize(dic.Count, 8) = Application.Transpose(Application.Transpose(dic.items))
' эта строчка выдаст сообщение, если какие-то папки не обработались
If dicFail.Count > 0 Then MsgBox "Не обработались папки: " & Join(dicFail.keys, ", ")
End Sub