Option Explicit

Sub ImportData()
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim strSQL$, strCnnString$, strFile$, Sheet$, strMask$, strPath As String
    Dim intRngRw%, intRngRw2%, i%

'литс тоже указала свой
    Sheet$ = "Лист1"
    i = Application.WorksheetFunction.CountA(Sheets(Sheet$).Columns( 1 )) +  1 

'здесь путь поменяла
    strPath = "D:\Documents and Settings\Administrator\My Documents\2"
    strMask$ = "Книга2*.xls" ' название первое из книг которое надо скопировать
    strFile$ = Dir(strPath & strMask$)
    Do While strFile$ <> ""
    Debug.Print strFile$
        intRngRw =  1 
        intRngRw2 =  2 
        Do
            Set cnn = New ADODB.Connection
            Set rst = New ADODB.Recordset
            
            strSQL = "SELECT * FROM" & "[" & Sheet & "$A" & intRngRw & ":" & "A" & intRngRw2 & "]" ' у меня только первый столбец, поэтому заменила на А

            strCnnString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & strPath & strFile$ & ";" & "Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"""   ' не меняла ничего
            'strCnnString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath & strFile$ &  ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""

            cnn.Open strCnnString
            rst.Open strSQL, cnn, adOpenStatic, adLockReadOnly
         

            If rst.Fields( 0 ) = "" Then Exit Do
            Cells(i,  1 ).CopyFromRecordset rst
            intRngRw = intRngRw +  1 
            intRngRw2 = intRngRw2 +  1 
            i = i +  1 
            rst.Close
            cnn.Close
            Set cnn = Nothing
            Set rst = Nothing
        Loop
        strFile$ = Dir
    Loop
End Sub

Sub ImportData_1()
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim strSQL$, strCnnString$, strFile$, Sheet$, strMask$, strPath As String
    Dim intRngRw%, intRngRw2%, i%

    Sheet$ = "Ëèñò1"
    i = Application.WorksheetFunction.CountA(Sheets(Sheet$).Columns( 1 )) +  1 

'çäåñü óêàçàí ïóòü
    strPath = "D:\Documents and Settings\Administrator\My Documents\2\"
    strMask$ = "Êíèãà2*.xls" 
    strFile$ = Dir(strPath & strMask$)
    Do While strFile$ <> ""
    Debug.Print strFile$
        intRngRw =  1 
        intRngRw2 =  2 
        Do
            Set cnn = New ADODB.Connection
            Set rst = New ADODB.Recordset
            
            strSQL = "SELECT * FROM" & "[" & Sheet & "$A" & intRngRw & ":" & "A" & intRngRw2 & "]" 
            strCnnString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & strPath & strFile$ & ";" & "Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"""
            'strCnnString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath & strFile$ &  ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""

            cnn.Open strCnnString
            rst.Open strSQL, cnn, adOpenStatic, adLockReadOnly
         

            If rst.Fields( 0 ) = "" Then Exit Do
            Cells(i,  1 ).CopyFromRecordset rst
            intRngRw = intRngRw +  1 
            intRngRw2 = intRngRw2 +  1 
            i = i +  1 
            rst.Close
            cnn.Close
            Set cnn = Nothing
            Set rst = Nothing
        Loop
        strFile$ = Dir
    Loop
End Sub