Public Function ADO_R_Dmitry(ByVal strSql$, ByVal FilePath$, ByVal OutputRange As Range, _
ByVal FieldsName As Boolean, ByVal OutputFieldsName As Boolean, ByVal version As Long)

Dim sCon As String, FieldName As String
Dim rs As Object, cn  As Object

Set rs = CreateObject("ADODB.Recordset")
Set cn = CreateObject("ADODB.Connection")
If FieldsName Then FieldName = "Yes" Else FieldName = "No"
Select Case version 'CLng(Split(Application.version, ".")(0))
    Case Is =  8 
        sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FilePath _
          & ";Extended Properties=""Excel 8.0;HDR=" & FieldName & ";IMEX=1"";"
    Case Is =  12 
        sCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FilePath _
        & ";Extended Properties=""Excel 12.0;HDR=" & FieldName & ";IMEX=1"";"
End Select

cn.Open sCon
If Not cn.State =  1  Then Exit Function
Set rs = cn.Execute(strSql)
If Not FieldsName Then OutputFieldsName = False
 If OutputFieldsName Then
    For i =  0  To rs.Fields.Count -  1 
    OutputRange.Offset( 0 , i) = rs.Fields(i).Name
    Next
    Set OutputRange = OutputRange.Offset( 1 ,  0 )
 End If
OutputRange.CopyFromRecordset rs
rs.Close:  cn.Close
Set cn = Nothing: Set rs = Nothing
End Function
Sub zapolnim()
Range("a1:c100000").Value = Range("a1:c1").Value
strSql2 = "SELECT * FROM [Лист1$]"
Call ADO_R_Dmitry(strSql2, ThisWorkbook.FullName, Sheets( 2 ).[a1], False, False,  8 )
Call ADO_R_Dmitry(strSql2, ThisWorkbook.FullName, Sheets( 3 ).[a1], False, False,  12 )
End Sub

Sub test()
Range("a1:c100000").Value = Array( 1 ,  2 ,  3 )
   ODBCGetData _
    "Driver={Microsoft Excel Driver (*.xls)};DBQ=" & ActiveWorkbook.Path & "\" & ActiveWorkbook.Name, _
    "SELECT * FROM [" & ActiveSheet.Name & "$]", _
   Sheets( 2 ).Cells( 1 ,  1 )
   Sheets( 2 ).Activate
  MsgBox "К-во строк :  " & Cells(Rows.Count,  1 ).End(xlUp).Row
End Sub