To Specifically export a sql query to a Excel workbook

Access 2010
Excel 2010

vba routine to export chnage to specific columns on a excel workbook template.

I have a query setup to export.
Set NewQuery = CurrentDb.CreateQueryDef("Export_Temp_Subform_Query", sql)


strUserName = Environ("username")
strPath = "C:\Users\" & strUserName & "\desktop\Export_Temp_Subform_Query.xls"

    DoCmd.OutputTo acOutputQuery, "Export_Temp_Subform_Query", acFormatXLS, strPath, True


What I need:
To Specifically export to a Excel workbook.. called  "Export_InPut_Data.xlslx"

I need Field(0) in the recordset to go to ColumnA in the workbook.
I need Field(1) in the recordset to go to ColumnB  etc....

The cells on this workbook are FORMATTED  exactly as i need them.
I'm hoping when the export is completed the formatting stays in place in the EXCEL workbook ?


Thanks
Fordraiders
LVL 3
FordraidersAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Dale FyeOwner, Developing Solutions LLCCommented:
instead of using transferspreadsheet, I would recommend using Excel Automation, which would allow you to use the copyFromRecordset method to push data from Access into a specific cell in range in Excel.

On my way out of the office for a meeting, but do a search on "CopyFromRecordset" here in EE and you should find some code for that.

Dale
mbizupCommented:
This is code that I use to write to an existing worksheet.  The target spreadsheet's format will remain intact...

You'd call it like this:

ExportToFile "C:\MyFile.xlsx"

Open in new window


Function ExportToFile(sFilePath As String)
    Dim xlapp As Object
    Dim xlWB As Object
    Dim xlWS As Object
    'Dim sFilePath As String
    Dim s As String
    

    s = "SELECT * FROM SomeTable"
    
    Set xlapp = CreateObject("Excel.Application")
    Set xlWB = XLOpenWorkBook(xlapp, sFilePath, True)
    Set xlWS = xlWB.worksheets(1)
    
    GenericExcelOutputToWorkbook xlapp, xlWS, xlWB, s, True
    
    
End Function

' Opens an existing workbook in an Excel Application Object
Function XLOpenWorkBook(xlapp As Object, sFileName As String, Optional blShow As Boolean = False) As Object
    On Error GoTo PROC_ERR
    Dim o As Object
    
    Set o = xlapp.Workbooks.Open(sFileName)
    'o.SaveAs filename:=sFileName, FileFormat:=51
    If blShow = False Then xlapp.WindowState = -4140
PROC_EXIT:
    Set XLOpenWorkBook = o
    Exit Function
PROC_ERR:
    MsgBox "ERROR " & Err.Number & " (XLOpenWorkBook): " & Err.description
    
End Function


Function GenericExcelOutputToWorkbook(oExcel As Object, oWS As Object, oWB As Object, sSelect As String, blDisplay As Boolean, Optional sTitle As String = "", Optional sSubTitle As String = "", Optional sSubTitle2 As String = "") As Boolean
'On Error GoTo ErrGenericExcelReport

    GenericExcelOutputToWorkbook = False

    Dim db As Database
    
    Dim rsGeneric As DAO.Recordset
    
    Set db = CurrentDb
    Set rsGeneric = db.OpenRecordset(sSelect, dbOpenDynaset, dbSeeChanges)
    
    Dim ColCount As Integer
    Dim col As Integer
    Dim row As Integer

    'Dim oWS As Object
    
   ' Set oWS = oExcel.ActiveSheet
    
'On Error GoTo ErrGenericExcelReport


    DoEvents
    
    ColCount = rsGeneric.Fields.Count
    row = 1
    col = 0
    With oWS
                     
        If (sTitle & "" <> "") Then row = row + 2       'set up for the title if there is one
        If (sSubTitle & "" <> "") Then row = row + 1       'set up for the subtitle if there is one
        If (sSubTitle2 & "" <> "") Then row = row + 1       'set up for the sub-subtitle if there is one
        
        .rows(row).Font.Bold = True
        
        'set up the Column Headings and
        Do While (col < ColCount)
            .cells(row, col + 1).Value = rsGeneric.Fields(col).Name
            
            col = col + 1
        Loop
        
        'output the data
        If rsGeneric.EOF Then
            row = row + 1
            col = 0
            .cells(row, col + 1).Value = "There are no records to display."
            .range(.cells(row, col + 1), .cells(row, ColCount)).merge
        End If
        
        Do While Not rsGeneric.EOF
            row = row + 1
            col = 0
            Do While (col < ColCount)
                .cells(row, col + 1).Value = rsGeneric.Fields(col)
                col = col + 1
            Loop
                        
            rsGeneric.MoveNext
        Loop
        
        .cells.EntireColumn.AutoFit
        On Error Resume Next
        If (sTitle & "" <> "") Then
            row = 1
            col = 0
            .rows(row).Font.Bold = True
            .cells(row, col + 1).Value = sTitle
            .cells(row, col + 1).WrapText = False
            .cells(row, col + 1).Font.Size = 14
            .range(oWS.cells(row, col + 1), oWS.cells(row, ColCount)).merge
            .range(.cells(row, col + 1), .cells(row, ColCount)).HorizontalAlignment = -4108
        End If
        If (sSubTitle & "" <> "") Then
            row = 2
            col = 0
            .rows(row).Font.Bold = True
            .cells(row, col + 1).Value = sSubTitle
            .cells(row, col + 1).WrapText = False
            .cells(row, col + 1).Font.Size = 12
            .range(.cells(row, col + 1), .cells(row, ColCount)).merge
            .range(.cells(row, col + 1), .cells(row, ColCount)).HorizontalAlignment = -4108
        End If
        If (sSubTitle2 & "" <> "") Then
            row = 3
            col = 0
            .rows(row).Font.Bold = True
            .cells(row, col + 1).Value = sSubTitle2
            .cells(row, col + 1).WrapText = False
            .cells(row, col + 1).Font.Size = 12
            .range(.cells(row, col + 1), .cells(row, ColCount)).merge
            .range(.cells(row, col + 1), .cells(row, ColCount)).HorizontalAlignment = -4108
        End If
        
    End With


    oWB.Save  ' SpecialFolderPath("MyDocuments") & "\" & sFileName
    GenericExcelOutputToWorkbook = True
    '

    oExcel.Visible = True
    
    'Set oWS = Nothing

    
Exit Function

Excel_EH:
    DoEvents
    DoEvents
    MsgBox "An error occurred. Please close excel and try running the process again.", vbExclamation, "No Page Break Inserted"
Exit Function

ErrGenericExcelReport:
    MsgBox "An error occured while attempting to generate the report." & vbCrLf & Err.Number & ": " & Err.description
Exit Function
    
End Function

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.