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 my code:
Expand|Select|Wrap|Line Numbers
- 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.