Consulting

Results 1 to 5 of 5

Thread: Exporting Parameter Query to Excel

  1. #1

    Unhappy Exporting Parameter Query to Excel


    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!

    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
    .Range("A9").CopyFromRecordset rst

  2. #2
    VBAX Guru
    Joined
    Mar 2005
    Posts
    3,296
    Location
    I did it with a modified version of your 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"

  3. #3
    Quote Originally Posted by OBP
    I did it with a modified version of your 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?

  4. #4
    VBAX Guru
    Joined
    Mar 2005
    Posts
    3,296
    Location
    Using the Query Criteria
    forms![Formname]![Fieldname]

  5. #5

    Talking

    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!

    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •