Exporting Parameter Query to Excel

:help
I'm trying to automate exporting a parameter query to excel using code. I am using similar code to export a regular query without the parameter and it works great. Now I am getting a Runtime 5 error. What can I do to correct this? Below is the code and below that is the line where debugging starts with the error.

Thanks for any and all help!

I would also like to set this up to where the file is saved as the parameter date +1 just not sure how to do that.

Thanks again!

Code:

---

Private Sub NEKMH310_Click()
    On Error Resume Next
    Dim sCriteria As String
    Dim db As Database
    Dim rst As Recordset
    Dim objApp As Excel.Application
    Dim objBook As Excel.Workbook
    Dim objSheet As Excel.Worksheet
    Dim strTemplatePath As String
    Dim sOutput As String
    Dim qdf As DAO.QueryDef
    Dim prm As DAO.Parameter
    Set db = CurrentDb()
Set qdf = db.QueryDefs("10q_Daily_eKMH310_Charge_Data (NE)")
qdf![forms!10f_kmh310_publish!post_date] = [Forms]![10f_kmh310_publish]![Post_Date]
sCriteria = " 1 = 1 "
If COID <> "" Then
    sCriteria = sCriteria & " AND [10q_Daily_eKMH310_Charge_Data (NE)].COID = """ & COID & """"
End If
If RPT_DATE <> "" Then
    sCriteria = sCriteria & " AND [10q_Daily_eKMH310_Charge_Data (NE)].RPT_DATE like """ & RPT_DATE & """"
    End If
If DEPT <> "" Then
    sCriteria = sCriteria & " AND [10q_Daily_eKMH310_Charge_Data (NE)].DEPT = """ & DEPT & """"
    End If
If DEPT_Name <> "" Then
    sCriteria = sCriteria & " AND [10q_Daily_eKMH310_Charge_Data (NE)].DEPT_NAME = """ & DEPT_Name & """"
    End If
If PT_NAME <> "" Then
    sCriteria = sCriteria & " AND [10q_Daily_eKMH310_Charge_Data (NE)].PT_Name = """ & PT_NAME & """"
    End If
If PAT_ACCT <> "" Then
    sCriteria = sCriteria & " AND [10q_Daily_eKMH310_Charge_Data (NE)].PAT_acct = """ & PAT_ACCT & """"
    End If
If CDM <> "" Then
    sCriteria = sCriteria & " AND [10q_Daily_eKMH310_Charge_Data (NE)].CDM = """ & CDM & """"
    End If
If CDM_DESC <> "" Then
    sCriteria = sCriteria & " AND [10q_Daily_eKMH310_Charge_Data (NE)].CDM_DESC = """ & CDM_DESC & """"
    End If
If Post_Date <> "" Then
    sCriteria = sCriteria & " AND [10q_Daily_eKMH310_Charge_Data (NE)].POST_DATE = """ & Post_Date & """"
    End If
If TRANS_DATE <> "" Then
    sCriteria = sCriteria & " AND [10q_Daily_eKMH310_Charge_Data (NE)].TRANS_DATE = """ & TRANS_DATE & """"
    End If
If QTY <> "" Then
    sCriteria = sCriteria & " AND [10q_Daily_eKMH310_Charge_Data (NE)].QTY = """ & QTY & """"
    End If
If PT <> "" Then
    sCriteria = sCriteria & " AND [10q_Daily_eKMH310_Charge_Data (NE)].PT = """ & PT & """"
    End If
If RVU <> "" Then
    sCriteria = sCriteria & " AND [10q_Daily_eKMH310_Charge_Data (NE)].RVU = """ & RVU & """"
    End If
If AMOUNT <> "" Then
    sCriteria = sCriteria & " AND [10q_Daily_eKMH310_Charge_Data (NE)].AMOUNT = """ & AMOUNT & """"
    End If
If BATCH <> "" Then
    sCriteria = sCriteria & " AND [10q_Daily_eKMH310_Charge_Data (NE)].BATCH = """ & BATCH & """"
    End If
'This is new
    strTemplatePath = "W:\HER\HER - Administration\revops\RevOps_Databases\Monarch\ROSS_Uploads\01 - Daily\Excel Templates\NE_EKMH310 (2010-02-23).xlt" ' template file reference
    sOutput = "W:\HER\HER - Patient Access Management\PasCoord\Process Improvement Team\Jason\Revops\NE_eKMH310" & " (" & Format(Date, "yyyy-mm-dd") & ").xls" 'output file name and path
'This is new
    Set objApp = New Excel.Application
    'This is new 'Your excel spreadsheet file goes here
    Set objBook = objApp.Workbooks.Add(strTemplatePath)
    'Name of sheet you want to export to
    Set objApp = objBook.Parent
    Set objSheet = objBook.Worksheets("KMH310")
    objBook.Windows(1).Visible = True
    'Opens the recordset and sets the variable
With objSheet
    .Select
    'Clears the current contents in the workbook range
    .Range("A9:O65000").ClearContents
    'rst Copies the recordset into the worksheet
    .Range("A9").CopyFromRecordset rst
    End With
    objBook.SaveAs (sOutput)
    objBook.Close
    rst.Close
    objApp.Visible = False
    Set rst = Nothing
    Set db = Nothing
    Set objSheet = Nothing
    Set objBook = Nothing
    Set objApp = Nothing
    MsgBox "NE eKMH310 has been published"
End Sub

---

Breaking point

Code:

---

.Range("A9").CopyFromRecordset rst

---

I did it with a modified version of your code

Code:

---

Set objApp = New Excel.Application
    'This is new 'Your excel spreadsheet file goes here
    Set objBook = objApp.Workbooks.Open("C:\Users\tonyosborn\Desktop\TMTR.xls")
    'Name of sheet you want to export to
    Set objSheet = objBook.Worksheets(1)
    objBook.Windows(1).Visible = True
    'Opens the Query recordset
    Set rst = CurrentDb.OpenRecordset("TAD Personnel Query")
    objSheet.Range("A2:R65000").Select
        'Clears the current contents in the workbook range
        With objApp.Application.Selection
    .ClearContents
        End With
        'rst Copies the recordset into the worksheet
        objSheet.Range("A2").CopyFromRecordset rst
    objBook.Save
    objBook.Close
    rst.Close
    objApp.Visible = False
    Set rst = Nothing
    Set objSheet = Nothing
    Set objBook = Nothing
    Set objApp = Nothing
    MsgBox "Excel has been Updated"

---

Quote:

---

Originally Posted by OBP

I did it with a modified version of your code

Code:

---

Set objApp = New Excel.Application
'This is new 'Your excel spreadsheet file goes here
Set objBook = objApp.Workbooks.Open("C:\Users\tonyosborn\Desktop\TMTR.xls")
'Name of sheet you want to export to
Set objSheet = objBook.Worksheets(1)
objBook.Windows(1).Visible = True
'Opens the Query recordset
Set rst = CurrentDb.OpenRecordset("TAD Personnel Query")
objSheet.Range("A2:R65000").Select
'Clears the current contents in the workbook range
With objApp.Application.Selection
    .ClearContents
End With
'rst Copies the recordset into the worksheet
objSheet.Range("A2").CopyFromRecordset rst
objBook.Save
objBook.Close
rst.Close
objApp.Visible = False
Set rst = Nothing
Set objSheet = Nothing
Set objBook = Nothing
Set objApp = Nothing
MsgBox "Excel has been Updated"

---

---

By using a form where would the parameters come from for the query?

Using the Query Criteria
forms![Formname]![Fieldname]

Searching other forums I was able to get help and piece together the correct code. I am posting it below

Thank you again for all of your help!

Code:

---

Private Sub NEKMH310_Click()
    On Error Resume Next
    Dim sCriteria As String
    Dim db As Database
    Dim rst As Recordset
    Dim objApp As Excel.Application
    Dim objBook As Excel.Workbook
    Dim objSheet As Excel.Worksheet
    Dim strTemplatePath As String
    Dim sOutput As String
    Dim qdf As DAO.QueryDef
    Dim prm As DAO.Parameter
    Set db = CurrentDb()
'construct the SELECT and FROM clauses of the query
    mySQL = "SELECT [10t_KMH310_Data].COID, ([Post_Date]+1) AS Rpt_Date, [10t_KMH310_Data].Dept_ID AS DEPT, "
    mySQL = mySQL & " [10t_KMH310_Data].Dept_Description AS DEPT_NAME, [10t_KMH310_Data].Pt_Name, [10t_KMH310_Data].Pt_Num AS PT_ACCT, "
    mySQL = mySQL & " [10t_KMH310_Data].CDM, [10t_KMH310_Data].CDM_Description AS CDM_DESC, [10t_KMH310_Data].Post_Date, "
    mySQL = mySQL & " [10t_KMH310_Data].Trans_Date, [10t_KMH310_Data].Qty, [10t_KMH310_Data].PT, [10t_KMH310_Data].RVU, "
    mySQL = mySQL & " [10t_KMH310_Data].Amount, [10t_KMH310_Data].Batch "
    mySQL = mySQL & " FROM [10t_KMH310_Data]"
'construct the WHERE Clause
If Nz(Me.Post_Date, "") = "" Then
    MsgBox "You must enter a post date"
    Me.Post_Date.SetFocus
    Exit Sub
    Else
    sCriteria = sCriteria & " [10t_KMH310_Data].POST_DATE = #" & Me.Post_Date & "#"
    End If
'add the WHERE Clause to the mySQL variable
mySQL = mySQL & " WHERE" & sCriteria
Debug.Print mySQL
'proceed with opening the recordset
 
Set rst = db.OpenRecordset(mySQL)
    'This is new
    strTemplatePath = "W:\HER\HER - Administration\revops\RevOps_Databases\Monarch\ROSS_Uploads\01 - Daily\Excel Templates\NE_EKMH310 (2010-02-23).xlt" ' template file reference
    sOutput = "W:\HER\HER - Patient Access Management\PasCoord\Process Improvement Team\Jason\Revops\NE_eKMH310" & " (" & Format([Post_Date] + 1, "yyyy-mm-dd") & ").xls" 'output file name and path set up to automatically save the file with the POST_Date +1
'This is new
    Set objApp = New Excel.Application
    'This is new 'Your excel spreadsheet file goes here
    Set objBook = objApp.Workbooks.Add(strTemplatePath)
    'Name of sheet you want to export to
    Set objApp = objBook.Parent
    Set objSheet = objBook.Worksheets("KMH310")
    objBook.Windows(1).Visible = True
    'Opens the recordset and sets the variable
'Set rst = db.OpenRecordset("10q_Daily_eKMH310_Charge_Data (NE)")
        With objSheet
    .Select
    'Clears the current contents in the workbook range
    .Range("A9:O65000").ClearContents
    'rst Copies the recordset into the worksheet
    .Range("A9").CopyFromRecordset rst
End With
    objBook.SaveAs (sOutput)
    objBook.Close
    rst.Close
    objApp.Visible = False
    Set rst = Nothing
    Set db = Nothing
    Set objSheet = Nothing
    Set objBook = Nothing
    Set objApp = Nothing
    MsgBox "NE eKMH310 has been published"
End Sub

---