Public Function ADO_R_Dmitry(ByVal StrSQL$, ByVal FilePath$, ByVal OutputRange As Range, _
ByVal FieldsName As Boolean, ByVal OutputFieldsName As Boolean)
'==============================================================================
'*Описание функции : Возвращает набор записей Recordset с первой ячейки адреса,
'* указанного диапазона.
'*strSql - Конструкция SQL  запроса.
'* FilePath - Полный путь к файлу включая имя и расширение.
'* OutputRange - адрес ячеки с которой начинается вывод данных.
'* FieldsName - используются или нет заголовки столбцов (True - False)
'* OutputFieldsName - вывод данных с заголовками или без (True - False), _
'* если FieldsName=False, заголовки не выводятся.
'==============================================================================
'* Автор R Dmitry (Дмитрий Русак dg_rusak@mail.ru skype: RDG_Dmitry)          |
'* WM:_R269866874234 U144446690328                                            |
'==============================================================================
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 CLng(Split(Application.Version, ".")( 0 ))
    Case Is <  12 
        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
 DoEvents
OutputRange.CopyFromRecordset rs
rs.Close:  cn.Close
Set cn = Nothing: Set rs = Nothing
End Function
Sub test()
Dim StrSQL$
Sheets( 1 ).[a1].CurrentRegion.ClearContents
StrSQL = "SELECT A.[MOB_NUM], A.[ACC], A.[TARIF_NAME], A.[NAME], A.[DILER_NAME], A.[ADATEFULL], A.[FD], A.[SIM_CARD_N], A.[DOGOVOR], A.[PDATE]" _
& " FROM [Лист1$] as A INNER JOIN " _
& "`C:\Documents and Settings\Дмитрий\Рабочий стол\тест\Реестр по ТС.xls`.[Лист1$] as b ON A.MOB_NUM = b.Федномер"
Call ADO_R_Dmitry(StrSQL, "C:\Documents and Settings\Дмитрий\Рабочий стол\тест\Активация.xls", Sheets( 1 ).[a1], True, True)
End Sub