I am trying to export the results of a query to excel.
I have my current code posted below.
with this...I can export the query as set up in the wizard to excel with no problems, however I want to be able to Query with parameters (ie select a date range, or specific employee) and then export that to excel.
What should I add, and where (I'm a pretty big novice!)
any help is much appreciated.
-Sean-
Option Compare Database
Public Function ExportRequest() 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 lRecords As Long
Dim iRow As Integer
Dim iCol As Integer
Dim iFld As Integer
Const cTabTwo As Byte = 1
Const cStartRow As Byte = 11
Const cStartColumn As Byte = 1
DoCmd.Hourglass True
' set to break on all errors
Application.SetOption "Error Trapping", 0
' start with a clean file built from the template file
' sTemplate = CurrentProject.Path & "\salary recovery template.xls"
sOutput = CurrentProject.Path & "\salary recovery template.xls"
' If Dir(sOutput) <> "" Then Kill sOutput
' FileCopy sTemplate, sOutput
' Create the Excel Applicaiton, Workbook and Worksheet and Database object
Set appExcel = Excel.Application
Set wbk = appExcel.Workbooks.Open(sOutput)
Set wks = appExcel.Worksheets(cTabTwo)
sSQL = "SELECT Employee_ID.[Account Name], Employee_ID.[Gen Ledg Acnt No], "
sSQL = sSQL & "Timesheettable1.[Job Number], Employee_ID.Type, Employee_ID.unknown, "
sSQL = sSQL & "Employee_ID.[Ref No], Employee_ID.[Recovery No], Timesheettable1.Employee, "
sSQL = sSQL & "Employee_ID.Rate, Timesheettable1.[Hours Worked], Timesheettable1.[Hours Paid]"
sSQL = sSQL & " FROM Employee_ID INNER JOIN Timesheettable1 ON Employee_ID.Employee = Timesheettable1.Employee;"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
If Not rst.BOF Then rst.MoveFirst
' For this template, the data must be placed on the 11th row, first column.
' (these values are set to constants for easy future modifications)
iCol = cStartColumn
iRow = cStartRow
Do Until rst.EOF
iFld = 0
lRecords = lRecords + 1
' Me.lblMsg.Caption = "Exporting record #" & lRecords & " to salary recovery template.xls"
' Me.Repaint
For iCol = cStartColumn To cStartColumn + (rst.Fields.Count - 1)
wks.Cells(iRow, iCol) = rst.Fields(iFld)
If InStr(1, rst.Fields(iFld).Name, "Date") > 0 Then
wks.Cells(iRow, iCol).NumberFormat = "mm/dd/yyyy"
End If
wks.Cells(iRow, iCol).WrapText = False
iFld = iFld + 1
Next
wks.Rows(iRow).EntireRow.AutoFit
iRow = iRow + 1
rst.MoveNext
Loop
ExportRequest = "Total of " & lRecords & " rows processed."
' Me.lblMsg.Caption = "Total of " & lRecords & " rows processed."
exit_Here:
' Cleanup all objects (resume next on errors)
On Error Resume Next
Set wks = Nothing
Set wbk = Nothing
Set appExcel = Nothing
Set rst = Nothing
Set dbs = Nothing
DoCmd.Hourglass False
Exit Function
err_Handler:
ExportRequest = Err.Description
' Me.lblMsg.Caption = Err.Description
Resume exit_Here
End Function
Private Sub cmdsearch_Click()
On Error GoTo err_Handler
MsgBox ExportRequest, vbInformation, "Finished"
Application.FollowHyperlink CurrentProject.Path & "\salary recovery template.xls"
exit_Here:
Exit Sub
err_Handler:
MsgBox Err.Description, vbCritical, "Error"
Resume exit_Here
End Sub
I have my current code posted below.
with this...I can export the query as set up in the wizard to excel with no problems, however I want to be able to Query with parameters (ie select a date range, or specific employee) and then export that to excel.
What should I add, and where (I'm a pretty big novice!)
any help is much appreciated.
-Sean-
Option Compare Database
Public Function ExportRequest() 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 lRecords As Long
Dim iRow As Integer
Dim iCol As Integer
Dim iFld As Integer
Const cTabTwo As Byte = 1
Const cStartRow As Byte = 11
Const cStartColumn As Byte = 1
DoCmd.Hourglass True
' set to break on all errors
Application.SetOption "Error Trapping", 0
' start with a clean file built from the template file
' sTemplate = CurrentProject.Path & "\salary recovery template.xls"
sOutput = CurrentProject.Path & "\salary recovery template.xls"
' If Dir(sOutput) <> "" Then Kill sOutput
' FileCopy sTemplate, sOutput
' Create the Excel Applicaiton, Workbook and Worksheet and Database object
Set appExcel = Excel.Application
Set wbk = appExcel.Workbooks.Open(sOutput)
Set wks = appExcel.Worksheets(cTabTwo)
sSQL = "SELECT Employee_ID.[Account Name], Employee_ID.[Gen Ledg Acnt No], "
sSQL = sSQL & "Timesheettable1.[Job Number], Employee_ID.Type, Employee_ID.unknown, "
sSQL = sSQL & "Employee_ID.[Ref No], Employee_ID.[Recovery No], Timesheettable1.Employee, "
sSQL = sSQL & "Employee_ID.Rate, Timesheettable1.[Hours Worked], Timesheettable1.[Hours Paid]"
sSQL = sSQL & " FROM Employee_ID INNER JOIN Timesheettable1 ON Employee_ID.Employee = Timesheettable1.Employee;"
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
If Not rst.BOF Then rst.MoveFirst
' For this template, the data must be placed on the 11th row, first column.
' (these values are set to constants for easy future modifications)
iCol = cStartColumn
iRow = cStartRow
Do Until rst.EOF
iFld = 0
lRecords = lRecords + 1
' Me.lblMsg.Caption = "Exporting record #" & lRecords & " to salary recovery template.xls"
' Me.Repaint
For iCol = cStartColumn To cStartColumn + (rst.Fields.Count - 1)
wks.Cells(iRow, iCol) = rst.Fields(iFld)
If InStr(1, rst.Fields(iFld).Name, "Date") > 0 Then
wks.Cells(iRow, iCol).NumberFormat = "mm/dd/yyyy"
End If
wks.Cells(iRow, iCol).WrapText = False
iFld = iFld + 1
Next
wks.Rows(iRow).EntireRow.AutoFit
iRow = iRow + 1
rst.MoveNext
Loop
ExportRequest = "Total of " & lRecords & " rows processed."
' Me.lblMsg.Caption = "Total of " & lRecords & " rows processed."
exit_Here:
' Cleanup all objects (resume next on errors)
On Error Resume Next
Set wks = Nothing
Set wbk = Nothing
Set appExcel = Nothing
Set rst = Nothing
Set dbs = Nothing
DoCmd.Hourglass False
Exit Function
err_Handler:
ExportRequest = Err.Description
' Me.lblMsg.Caption = Err.Description
Resume exit_Here
End Function
Private Sub cmdsearch_Click()
On Error GoTo err_Handler
MsgBox ExportRequest, vbInformation, "Finished"
Application.FollowHyperlink CurrentProject.Path & "\salary recovery template.xls"
exit_Here:
Exit Sub
err_Handler:
MsgBox Err.Description, vbCritical, "Error"
Resume exit_Here
End Sub