Sub CollectWorkbooksData()
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim CheckVal
    Dim strFile As String, strPath As String
    Dim strSQL As String, strSheet As String
    Dim lngRngRw1 As Long, lngRngRw2 As Long, lngLastCell As Long
    Dim strColumn1 As String, strColumn2 As String
    strPath = "D:\Excel\" '
    strFile = Dir(strPath)
    strSheet = "Лист1"
    lngLastCell = LastCell("Лист1",  1 ) +  1 
    Do While strFile <> ""
        'Выбираем диапазон например A1:G1
        strColumn1 = "A"
        lngRngRw1 =  1 
        strColumn2 = "G"
        lngRngRw2 =  1 
        Set cnn = New ADODB.Connection
        cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strPath & strFile & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"""
        Do 'Копируем данные построчно пока не встретится пустая ячейка в первом столбце
            strSQL = "SELECT * FROM" & "[" & strSheet & "$" & strColumn1 & lngRngRw1 & ":" & strColumn2 & lngRngRw2 & "]"
            On Error Resume Next
            Set rst = New ADODB.Recordset
            rst.Open strSQL, cnn
            CheckVal = rst( 0 ) 'Первое поле рекордсета, т.е ячейка в первом столбце
            If IsNull(CheckVal) Or IsEmpty(CheckVal) Then GoTo SKIP
            Range("A" & lngLastCell).CopyFromRecordset rst
            rst.Close
            Set rst = Nothing
            lngRngRw1 = lngRngRw1 +  1 : lngRngRw2 = lngRngRw2 +  1 : lngLastCell = lngLastCell +  1 
SKIP:             Loop Until IsNull(CheckVal) Or IsEmpty(CheckVal)
        Set cnn = Nothing
        strFile = Dir
    Loop
End Sub

Public Function LastCell(Sheet As String, Column As Long) As Long
    LastCell = Sheets(Sheet).Cells(Sheets(Sheet).Rows.Count, Column).End(xlUp).Row
End Function