Logo 
Search:

MS Office Answers

Ask Question   UnAnswered
Home » Forum » MS Office       RSS Feeds
  Question Asked By: Viveka Fischer   on Dec 06 In MS Office Category.

  
Question Answered By: Chione Massri   on Dec 06

I have been use the following code to export my data  to excel  from Access. Much
of what you see below is a current module using the export code. The key points
are the "Private Type" at the beginning, accessing your data via the query seen
below, of course you will use your own query, and then exporting  it out to Excel
via the "Sub prep" procedure. I bolded out the parts of greatest interest.

You will want to copy this into a module to better read it. The way the "Sub
prep" procedure works is it takes the query and basically copies it into a
matching size cell range within Excel. You can alter the starting point of the
range as shown below, and of course create your own headers.


Option Compare Database
Option Explicit
'Excel Objects
Public WST As Object ' OLE automation object
Public oExcel As New Excel.Application
Public sHyperLink As String
Private Type ExlCell
row As Long
col As Long
End Type
Sub ReportExport()
'* Query recordset, store data into an array, export to Excel based by
department
'* Each sheet  is formatted, and a summary report  is also created.
On Error GoTo ReportExport_Error:
'Our Excel type
Dim StartingCell As ExlCell
'Database Objects
Dim db As Database
Dim rsEmp As Recordset
Dim qryEmpString As String
'Arrays
Dim EmpArray() As Variant
Dim DeptArray() As String
Dim HeaderArray() As Variant
'Counters
Dim col As Integer
Dim row As Integer
Dim NumRecs As Integer 'This represents number of records per query
Dim i As Integer
'ProgressBar Vaiables
Dim iDeptAmount As Integer
'For the spreadsheet
Dim SheetName As String
Dim iRowCounter As Integer
Dim bNextCol As Boolean 'This moves data to next column, but is there a simpler
method?
Dim iDeptSplit As Integer 'Determines split for summary sheet data.
Dim iTotalEmployees As Integer 'This tallies all employees
'Prepare headers for report
HeaderArray() = Array("Last", "First", "Shift", "Hire Date")
'Prepare workbook
oExcel.Workbooks.Add
StartingCell.row = 1
StartingCell.col = 1
Set db = CurrentDb
DeptList DeptArray, db, iDeptSplit 'Get the department list
iRowCounter = 1 'For summary sheet
iTotalEmployees = 0 'For summary sheet
iDeptAmount = UBound(DeptArray) 'For progress bar
'Get list of employees based on department and export to Excel
For i = 0 To UBound(DeptArray) - 2
qryEmpString = ( _
"Select Employees.LName, Employees.FName, Employees.Shift,
Employees.DateHired, " & _
"Departments.DepartmentName From qryCompleteEmployeeList " & _
"Where (((Employees.DeptID) = " & DeptArray(i) & ") AND ((Employees.Term)=
No));")
Set rsEmp = db.OpenRecordset(qryEmpString, dbOpenDynaset)
IncreaseBar i, iDeptAmount
If rsEmp.EOF And rsEmp.BOF Then
Else
rsEmp.MoveLast
NumRecs = rsEmp.RecordCount
ReDim EmpArray(rsEmp.RecordCount + 1, rsEmp.Fields.Count)
rsEmp.MoveFirst
SheetName = rsEmp!DepartmentName
'Copy column headings into some array
For col = 0 To UBound(HeaderArray)
EmpArray(0, col) = HeaderArray(col)
Next
'Get employee data
For row = 1 To rsEmp.RecordCount
For col = 0 To rsEmp.Fields.Count - 1
EmpArray(row, col) = rsEmp.Fields(col).Value
Next
rsEmp.MoveNext
Next
iTotalEmployees = iTotalEmployees + NumRecs 'For summary sheet total
Prep StartingCell, NumRecs, rsEmp, EmpArray, SheetName '1) Send data to
excel
CheckCount iRowCounter, bNextCol, iDeptSplit '2)Determines split for
summary sheet
SummarySheet iRowCounter, NumRecs, bNextCol '3) Enter data onto summary
sheet
End If
rsEmp.Close 'Closes each instance after we use it
Next
oExcel.Sheets("Sheet1").Select
FormatSummarySheet bNextCol, iTotalEmployees 'Format Summary Sheet
oExcel.Application.Visible = True 'Show report to user.
ReportExport_Exit:
'Clean House
Set WST = Nothing
Set oExcel = Nothing
db.Close
Exit Sub

ReportExport_Error:
MsgBox Err.Description
MsgBox Err.Number
Resume ReportExport_Exit:

End Sub
Sub Prep(stCell As ExlCell, RecNum As Integer, SN As Recordset, TheArray As
Variant, _
NameSheet As String)
Dim sReturnLink As String
'Prep the Excel Workbook
oExcel.ActiveWorkbook.Sheets.Add
Set WST = oExcel.ActiveWorkbook.Sheets(1)
WST.Name = NameSheet
'Copy data out to Excel
WST.Range(WST.Cells(stCell.row, stCell.col), _
WST.Cells(stCell.row + SN.RecordCount + 1, _
stCell.col + SN.Fields.Count)).Value = TheArray
'Return link to main sheet
sReturnLink = "A" & RecNum + 4
sHyperLink = "Sheet1!A1"
With oExcel
.Range(sReturnLink).Value = "Return"
.ActiveSheet.Hyperlinks.Add Anchor:=.Range(sReturnLink), Address:="",
SubAddress:= _
sHyperLink
End With
'Format data
ExcelFormat RecNum
End Sub

Share: 

 

This Question has 1 more answer(s). View Complete Question Thread

 
Didn't find what you were looking for? Find more on Help in exporting Access Database Or get search suggestion and latest updates.


Tagged: