Sub RstToXLS(strSQL As String, strBook As String)
'strSQL - текст запроса
'strBook - путь и имя книги (без расширения)
On Error GoTo ErrHand
Dim rst As Recordset
Set rst = CurrentDb.OpenRecordset(strSQL)
Dim xls As New Excel.Application, wb As Excel.Workbook
xls.Workbooks.Add
Set wb = xls.ActiveWorkbook
Dim i As Long, j As Integer, k As Integer
j = rst.Fields.Count
Do Until rst.EOF
    i = i +  1 
    For k =  1  To j
        Cells(i, k).Value = rst.Fields(k -  1 )
    Next
    rst.MoveNext
Loop
wb.SaveAs strBook &  ".xls" 
wb.Close
xls.Quit

ErrHand:
rst.Close
Set rst = Nothing
Set xls = Nothing
End Sub