Exporting Access Query to Excel 3

[SHAWTY721]

I am trying to send the results of a query that runs when a button is clicked on a form. Originally I used teh DoCmd.TransferSpreadsheet to export the information but I was informed that by using the DoCmd.TransferSpreadsheet method you are unable to dictate which fields records should go to so I created a Public Function. I receive this error when I click the button: 'Run-time error ‘3061’:
To few parameters. Expected 4.'

This is what my function looks like:
Public Function ExportQuery() As String
On Error GoTo err_Handler

'Excel object variables
Dim appExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim wks As Excel.Worksheet

Dim sTemplate As String
Dim sTempFile As String
Dim sOutput As String

Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim sSQL As String
Dim IRecords As Long
Dim iRow As Integer
Dim iCol As Integer
Dim iFld As Integer

Const cTabOne As Byte = 1
Const cTabTwo As Byte = 2
Const cStartRow As Byte = 3
Const cStartColumn As Byte = 1

DoCmd.Hourglass True

'Set to break on all errors
Application.SetOption "Error Trapping", 0

'Start with clean file built from template file
sTemplate = CurrentProject.Path & "\JournalEntryTest.xls"
sOutput = CurrentProject.Path & "\JournalEntryFormTest.xls"
If Dir(sOutput) <> "" Then Kill sOutput
FileCopy sTemplate, sOutput

'Create the Excel Application, Workbook and Worksheet and Database object
Set appExcel = New Excel.Application
appExcel.Visible = True
Set wbk = appExcel.Workbooks.Open(sOutput)

sSQL = "SELECT * FROM qryJEtest"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
If Not rst.BOF Then
rst.MoveFirst
'For this template, the data must be placed in the appropriate cells of the spreadsheet
Do While Not rst.EOF
With wbk
.Sheets("JournalEntry").Range("G3") = rst.Fields("Branch Number")
.Sheets("JournalEntry").Range("K15") = rst.Fields("Account")
.Sheets("JournalEntry").Range("L15") = rst.Fields("Sub Account")
.Sheets("JournalEntry").Range("O15") = rst.Fields("SUMOfGROSS")
.Sheets("JournalEntry").Range("Q15") = rst.Fields("Account Description")
.Sheets("JournalEntry").Range("G3,K15,L15,O15,Q15").Columns.AutoFit
.SaveAs CurrentProject.Path & "\" & rst.Fields("Branch Number&""&Description") & " .xls"
End With
rst.MoveNext
Loop
rst.Close

ExportQuery = "Total of " & IRecords & " rows processed."

exit_Here:
'Cleanup all objects (resume next on errors)
Set wbk = Nothing
appExcel.Quit
Set appExcel = Nothing
Set rst = Nothing
Set dbs = Nothing
DoCmd.Hourglass False
Exit Function

err_Handler:
ExportQuery = Err.Description
Resume exit_Here
End If
End Function

 

[lameid]

Nothing jumps out at me. I recommend you comment out the on error line and hit debug when you get the error so you know which line is causing the error. Reading help on the method should be easy enough.

 

[henniec]

I do not know why you get that error. Someone here maybe able to enlighten both of us. What I normally do when I get that error is to create a table from the query and use the table as the export object. It may not be the best solution but it works for me.

Regarding the DoCmd.TransferSpreadsheet method I use ".Range("A2").CopyFromRecordset rs1" to export my recordset to Excel. This would transfer the complete record set to Excel. Not sure what how you could split the fields to place it it non adjacent columns.

What you could try to do is to transfer the recordset to Excel, do a manual macro in Excel and try to adapt it in Access to move the columns where needed.

I hope it helps.

Hennie

 

[JerryKlmns]

SHAWTY721

Obviously, qryJEtest is a paremeter query. You have to feed those 4 values before you open a recordset using it, or build the SQL statement for the source property of the recordset on the fly. When you open the recordset check both .BOF and .EOF for true. If not, since it is a DAO.Recordset, you then .MoveFirst

henniec
CopyFromRecordset method of the Range object dumps all records to a continuous range of cells. That's not what SHAWTY721 wants. That's why automation was suggested.

 

[SHAWTY721]

Okay I created the following SQL SELECT statement for the parameterized values and I am having some issues with trying to get a date time frame to work. Here is what the code looks like
{sSQL = "SELECT * FROM tblAllPerPayPeriodEarnings " & vbCrLf & "WHERE PG = '" & Forms("frmJE").Controls("cboADPCompany").Value & "' AND LOCATION# = '" & Forms("frmJE").Controls("cboLocationNo").Value & "' AND CHECK_DT = '" & Forms("frmJE").Controls("txtFrom").Value & "' & '" & Forms("frmJE").Controls("txtTo").Value & ";"}

The error is appearing with the CHECK_DT parameters using two different text boxes to determine which records should be displayed.

 

[lameid]

Things to note:

You have to repeate the field for every value you want to test or use between. (I assumed between).

Fields with special characters and spaces have to be enclosed with square brackes.

The date delimeter is # not '

sSQL = "SELECT * " & _
    "FROM tblAllPerPayPeriodEarnings " & _
    "WHERE PG = '" & Forms("frmJE").Controls("cboADPCompany").Value & _ 
    "' AND LOCATION# = '" & _
    Forms("frmJE").Controls("cboLocationNo").Value & _ 
    "' AND CHECK_DT Between #" & _ 
    Forms("frmJE").Controls("txtFrom").Value & _ 
    "# AND " & Forms("frmJE").Controls("txtTo").Value & "#" & _ 
    ";"}

 

[SHAWTY721]

Yes I wanted to use BETWEEN, now after I update my select statement I am still receiving an error message:
Run-time error ‘3075’:
Syntax error (missing operator) in query expression ‘PG = ‘RYU’ AND LOCATION# = ‘63’ AND CHECK_DT BETWEEN #9/1/2007# AND #9/30/2007#’.

 

[lameid]

I mentioned the square brackets and forgot to put them in...

[LOCATION#]

 

[SHAWTY721]

Okay it isn't giving me any errors messages now but it isn't writing the results from the query to the excel file that I have listed in the code.

Thanks for all the help!

 

[lameid]

I have code that uses the Excel application...it does something like:

With Excel App
   .Range("D2").Select
   .ActiveCell.FormulaR1C1 = "text"
End With

I think range should be valid off a sheet, so you might just try code similar using your sheet.

 

[JerryKlmns]

SHAWTY721,

Maybe this line is giving you the wrong result
.SaveAs CurrentProject.Path & "\" & rst.Fields("Branch Number&""&Description") & " .xls"

Shouldn't be

.SaveAs CurrentProject.Path & "\" & rst.Fields("Branch Number") & " " & rst.Fields("Description") & ".xls"

or something similar?

 

[SHAWTY721]

Even after I change the '.SaveAs CurrentProject.Path & "\" & rst.Fields("Branch Number") & " " & rst.Fields("Description") & ".xls"'. I still am getting nothing to write into excel based on the query result set.

 

[SHAWTY721]

Hi lameid, I was looking at your code and wondering exactly what it does and where exactly would I need to input this into my code?

 

[lameid]

It selects a Range (cell/D2) and sets its formula to a literal text value text.

The example works off the application object and therefore the active sheet but I don't see why it should not work off a sheet object (that is without testing it).

Try putting code like what is in the With block in your with block and see if it works.

 

[SHAWTY721]

I created a SQL statement that includes the join and parameters but I am getting
{Run-time error '3075': Syntax error (missing operator) in query expression ‘WHERE PG = ‘RYU’ AND [LOCATION#] = ‘63’ AND CHECK_DT Between #9/1/2007# AND #9/30/2007#’.}

The SQL Statement that is producing this error looks like this:
{ sSQL = "SELECT tblAllPerPayPeriodEarnings.GLDEPT, tblGLAllCodes.GL_Acct, tblGLAllCodes.GL_Subacct, tblGLAllCodes.GL_Dept, tblGLAllCodes.AccountDescription , tblAllADPCoCodes.BranchNumber, Sum(tblAllPerPayPeriodEarnings.GROSS) FROM tblAllADPCoCodes, tblGLAllCodes INNER JOIN tblAllPerPayPeriodEarnings ON tblGLAllCodes.Dept = tblAllPerPayPeriodEarnings.GLDEPT GROUP BY tblAllPerPayPeriodEarnings.GLDEPT, tblGLAllCodes.GL_Acct, tblGLAllCodes.GL_Subacct, tblGLAllCodes.GL_Dept, tblGLAllCodes.AccountDescription, tblAllPerPayPeriodEarnings.PG, tblAllPerPayPeriodEarnings.[LOCATION#], tblAllADPCoCodes.BranchNumber, tblAllPerPayPeriodEarnings.CHECK_DT, WHERE PG = '" & Forms("frmJE").Controls("cboADPCompany").Value & "' AND [LOCATION#] = '" & Forms("frmJE").Controls("cboLocationNo").Value & "' AND CHECK_DT Between #" & Forms("frmJE").Controls("txtFrom").Value & "# AND #" & Forms("frmJE").Controls("txtTo").Value & "#" & ";"}

 

[lameid]

Take out the comma before the where clause...

The below comma does not belong.

tblAllPerPayPeriodEarnings.CHECK_DT, WHERE

 

[SHAWTY721]

I still get that error even after removing the comma.

 

[lameid]

That is the only syntax error I am seeing.

Maybe you can break on the line after you build your string and get the value of the string in the immediate window. You could then copy and paste it inot a query's SQL view and switch to design. That should help find any SQL errors.

 

[SHAWTY721]

Now that I have figured out why the query was working. I have ran into another problem with getting the results from the query to write to the excel spreadsheet. Only one record that is returned from the query is being written into excel. Upon click the button that runs this function, it opens excel and cycles through all the results of the query and when it reaches the last record it leaves that one in the excel spreadsheet.
Also it isn't finding one of the fields that I have listed in the query from the table where the records are being pulled from.
Here is the updated code:

Public Function ExportQuery() As String
On Error GoTo err_Handler

    'Excel object variables
    Dim appExcel As Excel.Application
    Dim wbk As Excel.Workbook
    Dim wks As Excel.Worksheet
    
    Dim sTemplate As String
    Dim sOutput As String       'Output string to build up
    
    '
    Dim dbs As DAO.Database     'This is the database
    Dim rst As DAO.Recordset    'Retrieves value of field
    Dim sSQL As String          'SQL Statement
    Dim IRecords As Long
       
    Dim J As Long
    
    DoCmd.Hourglass True
    
    'Set to break on all errors
   On Error Resume Next
    
    'Start with clean file built from template file
    sTemplate = CurrentProject.Path & "\JournalEntryTest.xls"
    sOutput = CurrentProject.Path & "\JournalEntryFormTest.xls"
    If Dir(sOutput) <> "" Then Kill sOutput
    FileCopy sTemplate, sOutput
    
    'Create the Excel Application, Workbook and Worksheet and Database object
    Set appExcel = New Excel.Application            'Assigns objects to variables
    appExcel.Visible = True                         'Makes Excel session visible
    Set wbk = appExcel.Workbooks.Open(sOutput)
    
    sSQL = "SELECT  tblAllPerPayPeriodEarnings.GLDEPT, tblGLAllCodes.GL_Acct, tblGLAllCodes.GL_Subacct, tblGLAllCodes.GL_Dept, tblGLAllCodes.AccountDescription , tblAllADPCoCodes.BranchNumber, Sum(tblAllPerPayPeriodEarnings.GROSS) FROM tblAllADPCoCodes, tblGLAllCodes INNER JOIN tblAllPerPayPeriodEarnings ON tblGLAllCodes.Dept = tblAllPerPayPeriodEarnings.GLDEPT GROUP BY tblAllPerPayPeriodEarnings.GLDEPT, tblGLAllCodes.GL_Acct, tblGLAllCodes.GL_Subacct, tblGLAllCodes.GL_Dept, tblGLAllCodes.AccountDescription, tblAllPerPayPeriodEarnings.PG, tblAllPerPayPeriodEarnings.[LOCATION#], tblAllADPCoCodes.BranchNumber, tblAllPerPayPeriodEarnings.CHECK_DT HAVING PG = '" & Forms("frmJE").Controls("cboADPCompany").Value & "' AND [LOCATION#] = '" & Forms("frmJE").Controls("cboLocationNo").Value & "' AND BranchNumber = " & Forms("frmJE").Controls("txtBranchNo").Value & " AND CHECK_DT Between #" & Forms("frmJE").Controls("txtFrom").Value & "# AND #" & Forms("frmJE").Controls("txtTo").Value & "#" & ";"
            
    Set dbs = CurrentDb                                 'Opens database
    Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)   'Sets the record set to the query
    
Do Until rst.EOF
    With wbk.Sheets("JournalEntry")
    IRecords = IRecords + 1
        .Cells(3, 7).Value = rst.Fields("BranchNumber").Value
        .Cells(15, 11).Value = rst.Fields("GL_Acct").Value
        .Cells(15, 12).Value = rst.Fields("GL_Subacct").Value
        .Cells(15, 15).Value = rst.Fields("GROSS").Value    
        .Cells(15, 17).Value = rst.Fields("AccountDescription").Value

    End With
J = J + 1
rst.MoveNext
Loop

'Format
'wbk.Sheets("JournalEntry").Range("G3,K15,L15,O15,Q15").Column.AutoFit
'wbk.Save
wbk.Close True
    
    ExportQuery = "Total of " & IRecords & " rows processed."
    
exit_Here:
'Cleanup all objects (resume next on errors)
Set wbk = Nothing
appExcel.Quit
Set appExcel = Nothing
Set rst = Nothing
Set dbs = Nothing
DoCmd.Hourglass False
Exit Function

err_Handler:
    ExportQuery = Err.Description
    Resume exit_Here
End Function
[\CODE] 

I receive this error message "Run-time error '3265': Item not found in this collection" for this line of code: 
[CODE]
      .Cells(15, 15).Value = rst.Fields("GROSS").Value    
[\CODE]

 

[TwoOdd]

First I create and save the query in Access then use the following two sub procedures for exporting - The first sub procedure calls the second one and this allows you to export multiple queries to the same spreadsheet as multiple tabs - it also deletes the 3 default tabs that Excel Creates with a new file:

Private Sub cmd_TestQuery_Click()
On Error GoTo Err_cmd_TestQuery_Click
        
        Set objXL = New Excel.Application
        objXL.Visible = True
        Set objWkb = objXL.Workbooks.Add

    cmd_Export "Your Query Name Here", "Name you want for the Excel Tab Here"

    objWkb.Worksheets("Sheet1").Delete
    objWkb.Worksheets("Sheet2").Delete
    objWkb.Worksheets("Sheet3").Delete
Exit_cmd_TestQuery_Click:
    Exit Sub

Err_cmd_TestQuery_Click:
    MsgBox Err.Description
    Resume Exit_cmd_TestQuery_Click
    
End Sub


Private Sub cmd_Export(varQuery, varWorksheetName)
    Dim MySQL As String
    Dim rs As Recordset
    Dim intMaxCol As Integer
    Dim intMaxRow As Integer
    
    MySQL = varQuery
    Set rs = CurrentDb.OpenRecordset(MySQL, dbOpenSnapshot)

    intMaxCol = rs.Fields.Count
    If rs.RecordCount > 0 Then
        rs.MoveLast
        rs.MoveFirst
        intMaxRow = rs.RecordCount
        objWkb.Worksheets.Add
        objWkb.Worksheets(1).Name = varWorksheetName
        Set objSht = objWkb.Worksheets(varWorksheetName)
        With objSht
            Dim fldLoop As Field
            Dim fldCount As Integer
            fldCount = 1
            For Each fldLoop In rs.Fields
                .Cells(2, fldCount) = fldLoop.Name
                fldCount = fldCount + 1
            Next

	    'Once imported, you can now use Excel VBA to modify the spreadsheet
	    'Below are some examples
            .Range("A2").FormulaR1C1 = "Description"
            .Columns("B:G").NumberFormat = "$#,##0.00"
            .Cells.Select
            .Cells.EntireColumn.AutoFit
            .Cells(1, 1).Select

        End With
    End If
End Sub

Hope this helps

TwoOdd
--------------
Good judgment comes from experience, and experience comes from bad judgment.
-- Barry LePatner