Option Explicit

Dim NewLine As Integer, Col As Integer, ToSheet As Worksheet

' Фукция для нахождения последней строки
Public Function LastRow(Optional ws As Worksheet, Optional FindRange As String) As Long
  If ws Is Nothing Then Set ws = ActiveSheet
  If FindRange = "" Then FindRange = Cells.Address
  LastRow = ws.Range(FindRange).Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
End Function

Sub RegularCopy(FName As String)
  Dim openwb As Workbook, FromSheet As Worksheet, FromRangeName As String, Lrow As Long
  'Открытие исходной книги предполагается что файлы находятся в том же каталоге в папке исходные файлы
  'Для того чтобы макрос работал необходимо эту книгу запускать через меню ФАЙЛ - Открыть книгу!
  Workbooks.Open Filename:="Исходные данные\" & FName & ".XLS", UpdateLinks:=False
   Set openwb = ActiveWorkbook
   'наименование листа с которого будут копироваться данные, предполагается, что во всех книгах одинаковый
   Set FromSheet = openwb.Sheets("Данные")
   'Имя Диапазона, в котором искать последнюю строку
   FromRangeName = Range(Cells( 1 ,  1 ).Address, Cells(Rows.Count, Col).Address).Address
   
   'нахождение последней строки в диапазоне
   Lrow = LastRow(FromSheet, FromRangeName)
   
   'Копирование значений диапазона
   'первая строка для копирования берётся 3-я
   ToSheet.Range(Cells(NewLine,  1 ).Address, Cells(NewLine -  1  -  2  + Lrow, Col).Address).Value = _
   FromSheet.Range(Cells( 3 ,  1 ).Address, Cells(Lrow, Col).Address).Value
   
   NewLine = NewLine + Lrow -  2 
   
  'закрытие книги
  openwb.Close False
End Sub
Sub Выбрать_данные()
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
   
   '№ Последнего столбца для консолидации, первый считается "A".
   'Дейсвует как для исходных данных, так и для итоговых
   Col =  20 
   'Первая строка в которую заполняются значения
   NewLine =  3 
   'Лист на который будем копировать
   Set ToSheet = ThisWorkbook.Sheets("Лист2")
   'Открытие листа куда заполняются данные
   ToSheet.Select
   'Очистка предыдущих данных
   Range(Cells(NewLine,  1 ), Cells(Rows.Count, Col)).Clear
   
   'Запуск процедуры копирования по каждому файлу, сколько угодно раз.
   'В кавычках имя файла без расширения
   RegularCopy ("Файл1")
   RegularCopy ("Файл2")
   RegularCopy ("Файл3")

 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub

ption Explicit

Dim NewLine As Integer, Col As Integer, ToSheet As Worksheet

' Фукция для нахождения последней строки
Public Function LastRow(Optional ws As Worksheet, Optional FindRange As String) As Long
  If ws Is Nothing Then Set ws = ActiveSheet
  If FindRange = "" Then FindRange = Cells.Address
  LastRow = ws.Range(FindRange).Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
End Function

Sub RegularCopy(FName As String)
  Dim openwb As Workbook, FromSheet As Worksheet, FromRangeName As String, Lrow As Long, Frow As Long
  'Открытие исходной книги предполагается что файлы находятся в том же каталоге в папке исходные файлы
  'Для того чтобы макрос работал необходимо эту книгу запускать через меню ФАЙЛ - Открыть книгу!
  Workbooks.Open Filename:="Исходные данные\" & FName & ".XLS", UpdateLinks:=False
   Set openwb = ActiveWorkbook
   'наименование листа с которого будут копироваться данные, предполагается, что во всех книгах одинаковый
   Set FromSheet = openwb.Sheets("Данные")
   'Имя Диапазона, в котором искать последнюю строку
   FromRangeName = Range(Cells( 1 ,  1 ).Address, Cells(Rows.Count, Col).Address).Address
   
   'первая строка в диапазоне, которую нужно копировать
   Frow =  3 
   'нахождение последней строки в диапазоне
   Lrow = LastRow(FromSheet, FromRangeName)
   
   'Копирование значений диапазона
   ToSheet.Range(Cells(NewLine,  1 ).Address, Cells(NewLine - Frow + Lrow, Col).Address).Value = _
   FromSheet.Range(Cells(Frow,  1 ).Address, Cells(Lrow, Col).Address).Value
   
   NewLine = NewLine - Frow + Lrow +  1 
   
  'закрытие книги
  openwb.Close False
End Sub
Sub Выбрать_данные()
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
   
   '№ Последнего столбца для консолидации, первый считается "A".
   'Дейсвует как для исходных данных, так и для итоговых
   Col =  20 
   'Первая строка в которую заполняются значения
   NewLine =  3 
   'Лист на который будем копировать
   Set ToSheet = ThisWorkbook.Sheets("Лист2")
   'Открытие листа куда заполняются данные
   ToSheet.Select
   'Очистка предыдущих данных
   Range(Cells(NewLine,  1 ), Cells(Rows.Count, Col)).Clear
   
   'Запуск процедуры копирования по каждому файлу, сколько угодно раз.
   'В кавычках имя файла без расширения
   RegularCopy ("Файл1")
   RegularCopy ("Файл2")
   RegularCopy ("Файл3")

 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub

Dim cnW As ADODB.Connection
 Dim rs As ADODB.Recordset

Sub macr()
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim NullCel As String
    Dim IshFile As String
    
    Set cnn = New ADODB.Connection
    Set rst = New ADODB.Recordset
    IshFile = ThisWorkbook.Path & "\" & "Исход.xls"
    
    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
      "Data Source=" & IshFile & ";" & _
      "Extended Properties=""Excel 8.0;HDR=No;IMEX=1"""
            
    rst.Open "SELECT F1,F4 FROM [Лист1$A2:D100]", cnn
    'или весь лист rst.Open "[Лист1$]", cnn

    
    'Следующая после последней заполненной ячейки в первом столбце
    NullCel = Sheets("Лист1").Columns( 1 ).Find("*", , , , , xlPrevious).Offset( 1 ,  0 ).Address
    
    ThisWorkbook.Sheets("Лист1").Range(NullCel).CopyFromRecordset rst
 
    rst.Close
    cnn.Close
    
    Set rst = Nothing
    Set cnn = Nothing
End Sub