The following function allows you to output a query to a new Excel spreadsheet without saving it first. An Excel template is used to set the formatting for the spreadsheet.

Hope you find this useful! smile.gif


To use it:

1. Set up a reference to the Microsoft Excel 10.0 Object Library (Tools, References, select Microsoft Excel 10.0 Object Library from the list)

2. Create a /templates directory in the same location as your .mdb file. Open a blank spreadsheet in excel and save it as a template: blank.xlt

3. Call function sOutputQueryExcel "qryMyQuery", "blank.xlt", True. This will output the query to a blank spreadsheet with the field headings.

4. Format column headings, set column widths and delete all records. Save spreadsheet as a template: MyQuery.xlt in /templates.

5. Call function as sOutputQueryExcel "qryMyQuery", "MyQuery.xlt", False This will output query (without field headings) to a new spreadsheet with formatting set in template.

6. Repeat to produce templates for other queries.

CODE
[color="green"]’---------------------------------------------------------------------------------------[/color]
[color="green"]’ Procedure : sOutputQueryExcel[/color]
[color="green"]’ DateTime  : 24/11/2004 10:10[/color]
[color="green"]’ Author    : kyledwood www.utteraccess.com[/color]
[color="green"]’ Purpose   : Outputs specified query to a new Excel spreadsheet using specified template. [/color]
[color="green"]’             If bolHeaders = True, first row is Field headers. [/color]
[color="green"]’ [/color]
[color="green"]’             Please feel free to use this code but please keep this header intact. Kyle :-)[/color]
[color="green"]’ [/color]
[color="green"]’---------------------------------------------------------------------------------------[/color]
[color="green"]’ [/color]
Public Sub sOutputQueryExcel(strQuery As String, strExcelTemplate As String, bolHeaders As Boolean)
On Error GoTo Err_sOutputQueryExcel

    [color="green"]’Turn on hourglass[/color]
    DoCmd.Hourglass True
    
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim fld As Field
    
    Dim appExcel As Excel.Application
    Dim exlWorkbooks As Excel.Workbooks
    Dim exlRange As Excel.Range
    Dim exlSelection As Object
    
    Dim intRow As Integer [color="green"]’Row pointer[/color]
    Dim lngColumnASCII As Long [color="green"]’ASCII code for column pointer[/color]

    Set db = CurrentDb
    
    Set appExcel = GetObject(, "Excel.Application")
    Set exlWorkbooks = appExcel.Workbooks
    
    [color="green"]’Open a workbook using specified template in templates folder in same folder as CurrentDb[/color]
    exlWorkbooks.Add Left$(CurrentDb.Name, Len(CurrentDb.Name) - Len(Dir(CurrentDb.Name))) _
    & "Templates\" & strExcelTemplate
    
    Set exlSelection = appExcel.Selection
    
    Set rst = db.OpenRecordset(strQuery)
    
    [color="green"]’Check records exist[/color]
    If rst.RecordCount > 0 Then
        
        [color="green"]’Row pointer starts at 1[/color]
        intRow = 1
        
        [color="green"]’Column pointer starts at 'A'[/color]
        lngColumnASCII = 65
        
        With rst
            
            .MoveFirst
            
            If bolHeaders Then
                
                [color="green"]’Loop through each field in record[/color]
                For Each fld In .Fields
                
                    [color="green"]’Set cell coordinates - column and row[/color]
                    Set exlRange = exlSelection.Range(Chr(lngColumnASCII) & CStr(intRow))
                    
                    [color="green"]’Inset name in cell[/color]
                    exlRange.Value = fld.Name
                    
                    [color="green"]’Increment column pointer[/color]
                    lngColumnASCII = lngColumnASCII + 1
                
                Next fld
                
                [color="green"]’Increment Row counter[/color]
                intRow = intRow + 1
                
                [color="green"]’Reset Column counter to 'A'[/color]
                lngColumnASCII = 65
            
            End If
            
            [color="green"]’Loop through recordset[/color]
            Do While Not .EOF

                [color="green"]’Loop through each field in record[/color]
                For Each fld In .Fields
                
                    [color="green"]’Set cell coordinates[/color]
                    Set exlRange = exlSelection.Range(Chr(lngColumnASCII) & CStr(intRow))
                    
                    [color="green"]’Inset value in cell[/color]
                    exlRange.Value = fld.Value
                    
                    [color="green"]’Increment column counter[/color]
                    lngColumnASCII = lngColumnASCII + 1
                    
                Next fld
                    
                [color="green"]’Increment Row pointer[/color]
                intRow = intRow + 1
                
                [color="green"]’Reset Column pointer to 'A'[/color]
                lngColumnASCII = 65
                
                .MoveNext
            Loop
            
        End With
        
        [color="green"]’Make worksheet visible[/color]
        appExcel.Application.Visible = True

    Else
    
        MsgBox "No records to export"
    
    End If
        
Exit_sOutputQueryExcel:
    
    [color="green"]’Turn off hourglass[/color]
    DoCmd.Hourglass False
    
    Set db = Nothing
    Set rst = Nothing
    
    Exit Sub
    
Err_sOutputQueryExcel:
    
    [color="green"]’Excel is not running[/color]
    If Err = 429 Then
        
        [color="green"]’Open Excel using CreateObject[/color]
        Set appExcel = CreateObject("Excel.Application")
        Resume Next
    
    [color="green"]’Other error[/color]
    Else
        
        MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
        Resume Exit_sOutputQueryExcel
    
    End If

End Sub