Форум по VBA и MS Office

    For Each sh_src In wb2.Worksheets
   
        ' Если в файле 2, в "B1" заданное значение.
        If sh_src.Range("B1").Value = "Дерево" Then
       
            ' Поиск на листе-результате последней строки.
                ' End не ищет в скрытых строках.
            lr = sh_res.Cells(sh_res.Rows.Count, "A").End(xlUp).row + 1
           
            ' Копирование данных из листа-источника на лист-результат.
            sh_res.Cells(lr, "A").Value = sh_src.Range("B2").Value
            sh_res.Cells(lr, "B").Value = sh_src.Range("B3").Value
            sh_res.Cells(lr, "C").Value = sh_src.Range("B4").Value
            sh_res.Cells(lr, "D").Value = sh_src.Range("B5").Value
            sh_res.Cells(lr, "E").Value = sh_src.Range("B6").Value
           
        End If
       
    Next sh_src

Sub макрос()

    Dim arr(), lr As Long, i As Long
   
    ' Поиск последней строки с учётом всех таблиц, а не нужной.
        ' Это нужно, чтобы записать данные в массив. С массивом макрос быстрее работает,
        ' чем с эксель-ячейками. Это нужно, если данных много.
        ' Весь столбец в массив не записываем, т.к. это наверное замедлит макрос.
        ' End не ищет в скрытых строках.
    lr = Cells(Rows.Count, "A").End(xlUp).Row
   
    ' Копируем данные в массив.
    arr() = Range("A1:A" & lr).Value
   
    ' Поиск конца нужной таблицы.
    For i = 10 To UBound(arr)
        ' Если макрос дошёл до пустой ячейки, то предполагается, что это конец таблицы.
        If arr(i, 1) = "" Then
            Exit For
        End If
    Next i
   
    ' Корректируем, если надо.
    lr = i - 1

End Sub