Export a Parameter Query to Excel…

It’s always tricky when you want export filtered data to Excel.  You will get an error message if you put try to put the Forms Control in the Criteria section of the Query.  Why?  Because Access insists on having the value before it can execute the export and not from the Form but directly in its SQL.  So, we will create the Query *on the fly*, export and then delete it, after all, no need to keep it as it will be recreated with new parameters for the next export.  Let’s get started…

Create your Template (Line 17) and make note of which row you want your Recordset (data) to start on (Line 30), as well as, cells that you want to populate in the header part of your spreadsheet, such as, the date (Line 26).  Then you will need the path of your Template and the path and naming convention of the saved worksheet (Line 43).

Copy/paste the Function SendToExcel into a Module… that said I usually put it behind the Filter Form because I am using a Template specific to a Recordset and I can use the same name for the Function and when I put the button on the Form I can keep that code the same, which a few minor changes.

Function SendToExcel(strTQName As String, strSheetName As String)
'Modified from http://btabdevelopment.com/export-a-table-or-query-to-excel-to-specific-worksheet/
' strTQName is the name of the table or query you want to send to Excel
' strSheetName is the name of the sheet you want to send it to

        Dim rst As DAO.Recordset
        Dim ApXL As Object
        Dim xlWBk As Object
        Dim xlWSh As Object
        Dim fld As DAO.Field
        Dim lngMaxRow As Long
        Dim lngMaxCol As Long
        Dim strPath As String

        On Error GoTo Err_Handler
            'Full Path and Name of Template
            strPath = "Full Path and Name of Template"

            Set rst = CurrentDb.OpenRecordset(strTQName)
            Set ApXL = CreateObject("Excel.Application")

            Set xlWBk = ApXL.Workbooks.Open(strPath)
            ApXL.Visible = True

            'Set xlWSh = xlWBk.Worksheets(strSheetName)
            'xlWSh.Range("A1").Value = Date

            rst.MoveFirst
           'The first row that you want your data to appear on
            xlWSh.Range("A5").CopyFromRecordset rst
            'Selects the first cell to unselect all cells
            xlWSh.Range("A5").Select
        'To apply Filters and to automatically resize the columns
        xlWSh.Activate
        xlWSh.Cells.Rows(4).AutoFilter
        xlWSh.Cells.Rows(4).EntireColumn.AutoFit

        rst.Close
        Set rst = Nothing
        'Remove prompts to save the Spreadsheet
        ApXL.DisplayAlerts = False
        'You will want to rename the Template so as to not overwrite it
        xlWBk.SaveAs "Full Path and Name of NEW Workbook", 51
        ApXL.DisplayAlerts = True
        'ApXL.Quit

        Exit Function
Err_Handler:
        DoCmd.SetWarnings True
        MsgBox Err.Description, vbExclamation, Err.Number
        Exit Function

End Function

Put a Command Button on your Form.  Now, we need to determine what type of Query you have, is it…

Straight SQL

strSQL = "SELECT... " & _
         "FROM..."

SQL with a Group By 

strSQL = "SELECT... " & _
         "FROM... " & _
         "GROUP BY..."

SQL with Criteria (WHERE) separate from what will be selected on the Form

strSQL = "SELECT... " & _
         "FROM... " & _
         "WHERE... " & _
         "ORDER BY..."

Not sure?  Go to Design View of the Query and then select SQL View (upper left hand corner).  Once you got which one scroll down to the appropriate section.

Then copy/paste the below between the Private Sub and End Sub.  You will need to modify the filtering portion to match the name of the Controls and your Recordsource accordingly.  Once done you can begin testing and adjusting.

Straight SQL

'Code from Allen Browne’s site (http://allenbrowne.com/ser-62code.html) modified

        Dim dbs As DAO.Database
        Dim qryDef As DAO.QueryDef
        Dim strSQL As String
        Dim strWhere As String
        Dim lngLen As Long
        Dim lngWhere As String

        Set dbs = CurrentDb

    'Put the SQL portion only of your Query here.
    strSQL = "SELECT…”

    'Text field example. Use quotes around the value in the string.
    If Not IsNull(Me.txtFilterCity) Then
        strWhere = strWhere & "([City] = """ & Me.txtFilterCity & """) AND "
    End If

    'Another text field example. Use Like to find anywhere in the field.
    If Not IsNull(Me.txtFilterMainName) Then
        strWhere = strWhere & "([MainName] Like ""*" & Me.txtFilterMainName & "*"") AND "
    End If

    'Number field example. Do not add the extra quotes.
    If Not IsNull(Me.cboFilterLevel) Then
        strWhere = strWhere & "([LevelID] = " & Me.cboFilterLevel & ") AND "
    End If

    'Yes/No field and combo example. If combo is blank or contains "ALL", we do nothing.
    If Me.cboFilterIsCorporate = True Then
        strWhere = strWhere & "([IsCorporate] = True) AND "
    ElseIf Me.cboFilterIsCorporate = 0 Then
        strWhere = strWhere & "([IsCorporate] = False) AND "
    End If

    'Date field example. Use the format string to add the # delimiters and get the right international format.
    If Not IsNull(Me.txtStartDate) Then
        strWhere = strWhere & "([EnteredOn] >= " & Format(Me.txtStartDate, conJetDate) & ") AND "
    End If

    'Another date field example. Use "less than the next day" since this field has times as well as dates.
    If Not IsNull(Me.txtEndDate) Then   'Less than the next day.
        strWhere = strWhere & "([EnteredOn] < " & Format(Me.txtEndDate + 1, conJetDate) & ") AND "
    End If

'I added an example for multi-select List Boxes
        If Me.lstRoleID.ItemsSelected.Count <> 0 Then
            'add selected values to string
            Set ctl = Me.lstRoleID
            For Each varItem In ctl.ItemsSelected
              'strWhere = strWhere & ctl.ItemData(varItem) & ","
              'Use this line if your value is text
              lngWhere = lngWhere & "'" & ctl.ItemData(varItem) & "',"
            Next varItem
            'trim trailing comma
            lngWhere = Left(lngWhere, Len(lngWhere) - 1)
            strWhere = strWhere & "stSourceType IN(" & lngWhere & ") AND "
        End If

    lngLen = Len(strWhere) - 5

    If lngLen <= 0 Then
        'If no selection is made then send everything to Excel
        strSQL = strSQL
        Set qryDef = dbs.CreateQueryDef("qrySendToExcel", strSQL)
        'DoCmd.OpenQuery qryDef.Name
        qryDef.Close
        Set qryDef = Nothing
        DoEvents
        Call SendToExcel("qrySendToExcel", "Sheet1")
        DoEvents
        DoCmd.DeleteObject acQuery, "qrySendToExcel"
    Else
        'Send filtered results to Excel
        strWhere = Left$(strWhere, lngLen)
        strSQL = strSQL & " WHERE " & strWhere
        Set qryDef = dbs.CreateQueryDef("qrySendToExcel", strSQL)
        'DoCmd.OpenQuery qryDef.Name
        qryDef.Close
        Set qryDef = Nothing
        DoEvents
        Call SendToExcel("qrySendToExcel", "Sheet1")
        DoEvents
        DoCmd.DeleteObject acQuery, "qrySendToExcel"
    End If

        dbs.Close
        Set dbs = Nothing

SQL with a Group By  *You will need to add the filtering from Straight SQL

        Dim dbs As DAO.Database
        Dim qryDef As DAO.QueryDef
        Dim strSQL As String
        Dim strWhere As String
        Dim strOrderBy As String
        Dim lngLen As Long
        Dim lngWhere As String

        Set dbs = CurrentDb

    'Put the SQL portion only of your Query here.
    strSQL = "SELECT…”

    strOrderBy = " ORDER BY quniMIForExcel.mySequence"

'ADD FILTERING FROM Straight SQL and adjust

    lngLen = Len(strWhere) - 5

    If lngLen <= 0 Then
        'If no selection is made then send everything to Excel
        strSQL = strSQL & strOrderBy
        Set qryDef = dbs.CreateQueryDef("qrySendToExcel", strSQL)
        'DoCmd.OpenQuery qryDef.Name
        qryDef.Close
        Set qryDef = Nothing
        DoEvents
        Call SendToExcel("qrySendToExcel", "Sheet1")
        DoEvents
        DoCmd.DeleteObject acQuery, "qrySendToExcel"
    Else
        'Send filtered results to Excel
        strWhere = Left$(strWhere, lngLen)
        strSQL = strSQL & " WHERE " & strWhere & strOrderBy
        Set qryDef = dbs.CreateQueryDef("qrySendToExcel", strSQL)
        'DoCmd.OpenQuery qryDef.Name
        qryDef.Close
        Set qryDef = Nothing
        DoEvents
        Call SendToExcel("qrySendToExcel ", "Sheet1")
        DoEvents
        DoCmd.DeleteObject acQuery, "qrySendToExcel"
    End If

        dbs.Close
        Set dbs = Nothing

SQL with Criteria separate from what will be selected on the Form  *You will need to add the filtering from Straight SQL

        Dim dbs As DAO.Database
        Dim qryDef As DAO.QueryDef
        Dim strSQL As String
        Dim strWhere As String
        Dim strQueryWhere As String
        Dim strOrderBy As String
        Dim lngLen As Long
        Dim lngWhere As String

        Set dbs = CurrentDb

    'Put the SQL portion only of your Query here.
    strSQL = "SELECT…”

    strOrderBy = " ORDER BY quniMIForExcel.mySequence"
    strQueryWhere = "(((tblLifts.lStatusID)=1 Or (tblLifts.lStatusID)=0) AND ((tblLifts.lTransferTo) Is Null) AND ((tblCoilRun.crNoShow)=False))"

'ADD FILTERING FROM Straight SQL and adjust

    lngLen = Len(strWhere) - 5

    If lngLen <= 0 Then
        'If no selection is made then send everything to Excel
        strSQL = strSQL & " WHERE " & strQueryWhere & strOrderBy
        Set qryDef = dbs.CreateQueryDef("qrySendToExcel", strSQL)
        'DoCmd.OpenQuery qryDef.Name
        qryDef.Close
        Set qryDef = Nothing
        DoEvents
        Call SendToExcel("qrySendToExcel", "Sheet1")
        DoEvents
        DoCmd.DeleteObject acQuery, "qrySendToExcel"
    Else
        'Send filtered results to Excel
        strWhere = Left$(strWhere, lngLen)
        strSQL = strSQL & " WHERE " & strQueryWhere & " AND " & strWhere & strOrderBy
        Set qryDef = dbs.CreateQueryDef("qrySendToExcel", strSQL)
        'DoCmd.OpenQuery qryDef.Name
        qryDef.Close
        Set qryDef = Nothing
        DoEvents
        Call SendToExcel("qrySendToExcel", "Sheet1")
        DoEvents
        DoCmd.DeleteObject acQuery, "qrySendToExcel"
    End If

        dbs.Close
        Set dbs = Nothing

Don’t forget to add error code!

 619 total views,  1 views today