CoolFactor
Technical User
MY CODE IS NEAR THE BOTTOM
I want to export this Access query into Excel using a command button on an Access form in the following way I describe below.
Below you will find the simple query I am trying to export to Excel using a command in an Access Form.
RowID strFY AccountID CostElementWBS
1 2008 1 7
2 2008 1 7
I want to export the 1st record of this query to an excel workbook in the following way:
In Workheet "Sheet1," I want the data pertaining to field strFY to go to Cell "A1," and then I want the data pertaining to field AccountID to go to Cell "A2."
Then in Worksheet "Sheet2," I want the data pertaining to field CostElementWBS to go to Cell "B1."
FOR THE SECOND RECORD IN THIS TABLE:
I want to export the 2nd record of this table to a new excel workbook in the following way:
In Workheet "Sheet1," I want the data pertaining to field strFY to go to Cell "A1," and then I want the data pertaining to field AccountID to go to Cell "A2." Then in Worksheet "Sheet2," I want the data pertaining to field CostElementWBS to go to Cell "B1."
Here is the code I'm using:
Option Compare Database
Option Explicit
Private Sub cmdauto_Click()
On Error GoTo err_Handler
MsgBox ExportRequest, vbInformation, "Finished"
exit_Here:
Exit Sub
err_Handler:
MsgBox Err.Description, vbCritical, "Error"
Resume exit_Here
End Sub
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 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 a clean file built from the template file
sTemplate = CurrentProject.Path & "\Test 1.xls"
' Create the Excel Applicaiton, Workbook and Worksheet and Database object
Set appExcel = New Excel.Application
appExcel.Visible = True
Set wbk = appExcel.Workbooks.Add(sTemplate)
Set wks = appExcel.Worksheets(cTabOne)
sSQL = "select * from qry_12"
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 4th row, third 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.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."
' My users appreciate when I resize the columns to fit the data.
wks.Cells.Select
wks.Cells.EntireColumn.AutoFit
' Set the focus back at the first cell
wks.Range("A1").Select
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
Resume exit_Here
End Function
A step by step process would be much appreciated. I've researching this for a the past 3 days with no luck, so I thank you many times over for your assistance.
Thank you.
I want to export this Access query into Excel using a command button on an Access form in the following way I describe below.
Below you will find the simple query I am trying to export to Excel using a command in an Access Form.
RowID strFY AccountID CostElementWBS
1 2008 1 7
2 2008 1 7
I want to export the 1st record of this query to an excel workbook in the following way:
In Workheet "Sheet1," I want the data pertaining to field strFY to go to Cell "A1," and then I want the data pertaining to field AccountID to go to Cell "A2."
Then in Worksheet "Sheet2," I want the data pertaining to field CostElementWBS to go to Cell "B1."
FOR THE SECOND RECORD IN THIS TABLE:
I want to export the 2nd record of this table to a new excel workbook in the following way:
In Workheet "Sheet1," I want the data pertaining to field strFY to go to Cell "A1," and then I want the data pertaining to field AccountID to go to Cell "A2." Then in Worksheet "Sheet2," I want the data pertaining to field CostElementWBS to go to Cell "B1."
Here is the code I'm using:
Option Compare Database
Option Explicit
Private Sub cmdauto_Click()
On Error GoTo err_Handler
MsgBox ExportRequest, vbInformation, "Finished"
exit_Here:
Exit Sub
err_Handler:
MsgBox Err.Description, vbCritical, "Error"
Resume exit_Here
End Sub
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 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 a clean file built from the template file
sTemplate = CurrentProject.Path & "\Test 1.xls"
' Create the Excel Applicaiton, Workbook and Worksheet and Database object
Set appExcel = New Excel.Application
appExcel.Visible = True
Set wbk = appExcel.Workbooks.Add(sTemplate)
Set wks = appExcel.Worksheets(cTabOne)
sSQL = "select * from qry_12"
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 4th row, third 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.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."
' My users appreciate when I resize the columns to fit the data.
wks.Cells.Select
wks.Cells.EntireColumn.AutoFit
' Set the focus back at the first cell
wks.Range("A1").Select
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
Resume exit_Here
End Function
A step by step process would be much appreciated. I've researching this for a the past 3 days with no luck, so I thank you many times over for your assistance.
Thank you.