Как произвести экспорт данных из базы Access в Excel

Sub Main()
    Dim myExcel As Object
    Const xlInsertDeleteCells = 1
'
    Set myExcel = CreateObject('Excel.Application')
'    
    myExcel.Workbooks.Add
'    
    With myExcel.ActiveSheet.QueryTables.Add(Connection:=Array(Array( _
        'ODBC;DSN=База данных MS Access;DBQ=C:Test.mdb;DefaultDir=C:;DriverId=25;FIL=MS' _
        ), Array(' Access;MaxBufferSize=2048;PageTimeout=5;')), Destination:=Range('A1'))
'        
        .CommandText = Array( _
            'SELECT Companies.CustomerID, Companies.ManagerID, Companies.Название' & Chr(13) & '' & Chr(10) & _
            'FROM `C:Test`.Companies Companies' & Chr(13) & '' & Chr(10) & 'WHERE (Co' _
            , 'mpanies.CustomerID>=1 And Companies.CustomerID<=55)' & Chr(13) & '' & Chr(10) & _
            'ORDER BY Companies.CustomerID')
'        
        .Name = 'Запрос из База данных MS Access'
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery:=False
    End With
'    
    With myExcel
        .ActiveWorkbook.SaveAs 'C:Test.xls'
        .ActiveWorkbook.Close
        .Application.Quit
    End With
'    
    Set myExcel = Nothing
'    
End Sub

Dim ExcelSheet As Object
Set ExcelSheet = CreateObject('Excel.Sheet')
ExcelSheet.SaveAs 'c:TEST.xls'

Dim appExc As Object
Dim wBook As Object
Dim wSheet As Object
Dim excFlName$
Dim NewEXC As Boolean
 
excFlName = App.Path & 'ReportsReports.xls'
    On Error Resume Next
    
    Set appExc = GetObject(, 'excel.application')
    NewEXC = False
    If err.Number <> 0 Then
        NewEXC = True
        Set appExc = CreateObject('excel.application')
            If appExc Is Nothing Then
                MsgBox 'Error: У Вас не установлено приложение MS Excell!'
                Exit Sub
            End If
    End If
    Set wBook = appExc.Workbooks.Open(excFlName)
    Set wSheet = wBook.Worksheets(1)
 
   wSheet.Cells(1, 2).Value = rsRep.Fields('tovar_name').Value
   wSheet.Cells(1, 3).Value = rsRep.Fields('cnt_nal').Value
   wSheet.Cells(1, 4).Value = rsRep.Fields('price_out').Value
   wSheet.Cells(1, 5).Value = rsRep.Fields('pays').Value
 
   wBook.Save
   wBook.Close
   If NewEXC = True Then
      'Если мы создали экземпляр Excel, то уничтожаем его       
      appExc.Quit
   End If
   Set wSheet = Nothing
   Set wBook = Nothing
   Set appExc = Nothing

 If Val(MyXL.Application.Version) >= 9 Then
   MyXL.Application.Range('A1').CopyFromRecordset RecordsetForExport
 else
   'вставка данных любым другим методом
 End If

Dim xl As Excel.Application
Dim wbk As Workbook
Dim wsh As Worksheet
Dim tmpStr$
Dim rsADO As ADODB.Recordset
 
....
Здесь открытие рекордсета твоей таблицы
....
 
Set xl = New Excel.Application
Set wbk = xl.Workbooks.Add
Set wsh = wbk.Worksheets(1)
 
tmpStr = rsADO.GetString(, , Chr(9), vbNewLine)
 
'Я тестил вот на этой строке и все ок было! Лень было писать запрос к базе!
'tmpStr = 'XPraptor' & Chr(9) & 'Cool Hacker' & vbNewLine & 'AND Cool' & Chr(9) & 'Programmer!' & vbNewLine
'А GetString вернет все записи таблицы в таком же виде
xl.Visible = True
wsh.Activate
Clipboard.SetText tmpStr
wsh.Paste Destination:=wsh.Range('A2')
 
Set wsh = Nothing
Set wbk = Nothing
Set xl = Nothing