Shiro,
here is a long post with lots of useful code for exporting to excel. I got
this from our discussion group some time ago. I am posting this as I don't
have time to write code to exactly suit your example.
Jeanette Cunningham
You will need to do this in Access. You can manipulate the Excel object
model from Access, but the syntax will be a little different that if you are
actually in Excel. The code below is much more than you need, but you can
use it to copy the pieces you do need into your own code. The important
part
when using automation between Access and Excel is how you open and close a
reference to Excel and how you refer to the Excel objects. If not done
correctly, it can create problems. So, enjoy (and post back if you need
help
understanding any of this)
Sub Build_XL_Report(strOutPut As String)
Const conLightGray As Long = 12632256
Const conLightBlue As Long = 16777164
Const conLightYellow As Long = 10092543
Dim ObjXLApp As Object 'Application Object
Dim objXLWkb As Object 'Workbook Object
Dim objXLws As Object 'Worksheet Object
Dim varGetFileName As Variant 'File Name with Full Path
Dim rstSCCB As Recordset 'Recordset to load data from
Dim rstItms As Recordset 'Recordset to load ITM Name in Header
Dim qdf As QueryDef 'Query def to load data
Dim lngItmCount As Long 'Number of ITMs in the RecordSet
Dim lngDetailCount As Long 'Number of Detail Data rows in the recordset
Dim intX As Integer 'Loop Counter
Dim strMonth As String 'Used to create a Short month name ie
January to Jan
Dim strCurrItm As String 'Hold the ITM Name to format Total cell
Dim lngRowCount As Long 'A loop counter that gives the current row
reference
Dim lngTotalPos As Long 'Used to format ITM Total cells
Dim strPrintArea As String 'Defines the print area for the sheet
Dim strTitleRows As String 'Defines the rows to print at the top of
each page
Dim strLeftRange As String 'Used to format range references
Dim strRightRange As String 'Used to format range references
Dim lngFirstDataRow As Long 'The first row with detail data
Dim lngLastDataRow As Long 'The last row with detail data
Dim blnExcelWasNotRunning As Boolean
Dim strDefaultDir 'Where to save spreadsheet
Dim strDefaultFileName 'Name to Save as
Dim lngFlags As Long 'Flags for common dialog
Dim strFilter As String 'File Display for Common Dialog
Dim strCurrMonth As String 'To create directory name for save
Dim strCurrYear As String 'To create directory name for save
Dim blnStopXl As Boolean 'Leave Open for Spreadsheet Version
On Error GoTo Build_XL_Report_ERR
DoCmd.Hourglass (True)
Me.txtStatus = "Updating Queries"
Me.txtStatus.Visible = True
'Fix the Queries so you dont have to be hand each month
Call FixSql("qselsccbactual", "actual_res_export")
Call FixSql("qselsccbactualtot", "actual_res_export")
Me.txtStatus = "Getting ITM Data"
Me.Repaint
'Set up the necessary objcts
On Error Resume Next ' Defer error trapping.
Set ObjXLApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
blnExcelWasNotRunning = True
Set ObjXLApp = CreateObject("excel.application")
Else
DetectExcel
End If
Err.Clear ' Clear Err object in case error occurred.
On Error GoTo Build_XL_Report_ERR
ObjXLApp.DisplayAlerts = False
ObjXLApp.Interactive = False
ObjXLApp.ScreenUpdating = False
Set objXLWkb = ObjXLApp.Workbooks.Add
Me.txtStatus = "Building Workbook"
Me.Repaint
'Remove excess worksheets
Do While objXLWkb.Worksheets.Count > 1
ObjXLApp.Worksheets(ObjXLApp.Worksheets.Count).Delete
Loop
Set objXLws = objXLWkb.ActiveSheet
'Build The Spreadsheet
'Build The Headers
Me.txtStatus = "Creating Headers"
Me.Repaint
strMonth = Left(Me.cboPeriod.Column(1), 3)
objXLws.Name = Me.cboResource & " Hours " & strMonth & " YTD"
With objXLws
.Cells(1, 1) = "ITM"
.Cells(1, 2) = Me.txtCurrYear & _
" Activity # Description"
.Cells(1, 3) = "Budget " & Me.txtCurrYear
.Cells(1, 4).Value = Me.txtCurrYear & " YTD Budget"
.Cells(1, 5) = "Actuals YTD"
.Cells(1, 6) = "Variance YTD"
.Cells(1, 7) = "TO GO"
.Cells(1, 8) = IIf(Me.cboPeriod >= 1, "JAN ACT", "JAN ETC")
.Cells(1, 9) = IIf(Me.cboPeriod >= 2, "FEB ACT", "FEB ETC")
.Cells(1, 10) = IIf(Me.cboPeriod >= 3, "MAR ACT", "MAR ETC")
.Cells(1, 11) = IIf(Me.cboPeriod >= 4, "APR ACT", "APR ETC")
.Cells(1, 12) = IIf(Me.cboPeriod >= 5, "MAY ACT", "MAY ETC")
.Cells(1, 13) = IIf(Me.cboPeriod >= 6, "JUN ACT", "JUN ETC")
.Cells(1, 14) = IIf(Me.cboPeriod >= 7, "JUL ACT", "JUL ETC")
.Cells(1, 15) = IIf(Me.cboPeriod >= 8, "AUG ACT", "AUG ETC")
.Cells(1, 16) = IIf(Me.cboPeriod >= 9, "SEP ACT", "SEP ETC")
.Cells(1, 17) = IIf(Me.cboPeriod >= 10, "OCT ACT", "OCT ETC")
.Cells(1, 18) = IIf(Me.cboPeriod >= 11, "NOV ACT", "NOV ETC")
.Cells(1, 19) = IIf(Me.cboPeriod >= 12, "DEC ACT", "DEC ETC")
End With
'Format Row 1
With objXLws
For Each cell In objXLws.Range("A1", "S1")
cell.Font.Size = 10
cell.Font.Name = "Arial"
cell.Font.Bold = True
cell.Interior.Color = conLightGray
cell.HorizontalAlignment = xlHAlignCenter
cell.WrapText = True
Next
.Cells(1, 2).HorizontalAlignment = xlHAlignLeft
.Columns("A").ColumnWidth = 9
.Columns("B").ColumnWidth = 39
.Columns("C:S").ColumnWidth = 9
.Rows(1).RowHeight = 25.5
End With
'Set Up Recordset for ITM Header data
Me.txtStatus = "Loading ITM Data"
Me.Repaint
Set qdf = CurrentDb.QueryDefs("qselSCCBhdr")
qdf.Parameters(0) = Me.cboResource
qdf.Parameters(1) = Me.cboPeriod
Set rstItms = qdf.OpenRecordset(dbOpenSnapshot, dbReadOnly)
'Be sure there are records to process
rstItms.MoveLast
rstItms.MoveFirst
lngItmCount = rstItms.RecordCount
If lngItmCount = 0 Then
MsgBox "No Data Found For This Report", vbInformation + vbOKOnly,
"Data Error"
GoTo Build_XL_Report_Exit
End If
'Load Header Data
objXLws.Cells(2, 1).CopyFromRecordset rstItms
rstItms.Close
Set rstItms = Nothing
Set qdf = Nothing
'Format the ITM Name Cells
Me.txtStatus = "Formatting Headers"
Me.Repaint
With objXLws
For Each cell In objXLws.Range("A2", "A" & Trim(str(lngItmCount + 2)))
cell.Font.Size = 10
cell.Font.Name = "Arial"
cell.Font.Bold = True
cell.Interior.Color = conLightGray
cell.HorizontalAlignment = xlHAlignLeft
cell.WrapText = False
Next
End With
'Merge the ITM Cells
For intX = 2 To lngItmCount + 2
strLeftRange = "A" & Trim(str(intX)) & ":B" & Trim(str(intX))
objXLws.Range(strLeftRange).MergeCells = True
Next intX
'Size the Blank Row
objXLws.Rows(lngItmCount + 3).RowHeight = 30
'Format Header Area and put in formulas
With objXLws
For intX = 2 To lngItmCount + 1
strLeftRange = "C" & Trim(str(intX))
strRightRange = "S" & Trim(str(intX))
For Each cell In objXLws.Range(strLeftRange, strRightRange)
cell.Font.Size = 10
cell.Font.Name = "Arial"
cell.Font.Bold = True
cell.Interior.Color = conLightBlue
cell.NumberFormat = "##,###,##0_);[Red](##,###,##0)"
Next
Next intX
'Do The Grand Total Row
strLeftRange = "C" & Trim(str(intX))
strRightRange = "S" & Trim(str(intX))
For Each cell In objXLws.Range(strLeftRange, strRightRange)
cell.Font.Size = 10
cell.Font.Name = "Arial"
cell.Font.Bold = True
cell.Interior.Color = conLightYellow
cell.Formula = "= Grand"
cell.NumberFormat = "##,###,##0_);[Red](##,###,##0)"
Next
End With
'Put Borders around the Header Area
With objXLws.Range("A1", "S" & Trim(str(lngItmCount + 2)))
.Borders(xlTop).LineStyle = xlContinuous
.Borders(xlTop).Weight = xlThin
.Borders(xlBottom).LineStyle = xlContinuous
.Borders(xlBottom).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).Weight = xlThin
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).Weight = xlThin
End With
'Add Total to ITM Names
For intX = 2 To lngItmCount + 1
objXLws.Cells(intX, 1) = "Grand Total " & objXLws.Cells(intX, 1)
Next intX
objXLws.Cells(intX, 1) = "Grand Total " & _
Me.cboResource & " HOURS"
'Copy the Header Row to the top of the Data Area
objXLws.Range("A1:S1").Copy _
Destination:=objXLws.Range("A" & Trim(str(intX + 2)))
'Load the Data
Me.txtStatus = "Loading Detail Data"
Me.Repaint
Set qdf = CurrentDb.QueryDefs("qselSCCBrpt")
qdf.Parameters(0) = Me.cboResource
qdf.Parameters(1) = Me.cboPeriod
Set rstSCCB = qdf.OpenRecordset(dbOpenSnapshot, dbReadOnly)
objXLws.Cells(intX + 3, 1).CopyFromRecordset rstSCCB
lngDetailCount = rstSCCB.RecordCount
rstSCCB.Close
Set rstSCCB = Nothing
Set qdf = Nothing
'Put in the SubTotals
Me.txtStatus = "Creating Subtotals"
Me.Repaint
lngFirstDataRow = intX + 3
lngLastDataRow = lngFirstDataRow + lngItmCount + lngDetailCount
With objXLws
.Range(.Cells(lngFirstDataRow - 1, 1), _
.Cells(lngLastDataRow, 19)).Subtotal groupBy:=1,
Function:=xlSum, _
totalList:=Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
16, 17, 18, 19)
End With
'Create Formulas and range names
For lngRowCount = lngFirstDataRow To lngLastDataRow
lngTotalPos = InStr(objXLws.Cells(lngRowCount, 1), "Total")
If lngTotalPos = 0 Then 'Column S needs to be light yellow if not a
total row
objXLws.Cells(lngRowCount, 5).Interior.Color = conLightYellow
objXLws.Cells(lngRowCount, 6).Interior.Color = conLightYellow
Else
strCurrItm = Left(objXLws.Cells(lngRowCount, 1), lngTotalPos -
2)
With objXLws
.Range("C" & Trim(str(lngRowCount)) & ":S" & _
Trim(str(lngRowCount))).Name = strCurrItm
.Range("A" & Trim(str(lngRowCount)) & ":S" & _
Trim(str(lngRowCount))).Interior.Color = conLightGray
End With
End If
Next lngRowCount
'Clear the subtotals
objXLws.Range("A:S").Copy
objXLws.Range("A:S").PasteSpecial (xlPasteValues)
objXLws.Range("A:S").RemoveSubtotal
objXLws.Cells(1, 1).Select 'Removes the selection
'Set the Margins, Headers and Footers
Me.txtStatus = "Formating Worksheet"
Me.Repaint
strPrintArea = "A1:S" & Trim(str(lngLastDataRow))
strTitleRows = 1 & ":" & Trim(str(lngItmCount + 3))
With objXLws.PageSetup
.Orientation = xlLandscape
.Zoom = False
.FitToPagesTall = False
.FitToPagesWide = 1
.CenterHeader = Me.txtCurrYear & " " & Me.cboResource _
& " Hours " & strMonth & " YTD"
.CenterFooter = "&F" & " " & "&D"
.RightFooter = "&R Page &P of &N"
.LeftMargin = ObjXLApp.InchesToPoints(0)
.RightMargin = ObjXLApp.InchesToPoints(0)
.TopMargin = ObjXLApp.InchesToPoints(0.5)
.BottomMargin = ObjXLApp.InchesToPoints(0.5)
.HeaderMargin = ObjXLApp.InchesToPoints(0.25)
.FooterMargin = ObjXLApp.InchesToPoints(0.25)
.PrintArea = strPrintArea
.PrintTitleRows = objXLws.Rows(strTitleRows).Address
End With
'Format the Data Area
With objXLws
strLeftRange = "A" & Trim(str(lngFirstDataRow))
strRightRange = "S" & Trim(str(lngLastDataRow))
For Each cell In objXLws.Range(strLeftRange, strRightRange)
cell.Font.Size = 10
cell.Font.Name = "Arial"
cell.Font.Bold = True
cell.NumberFormat = "##,###,##0_);[Red](##,###,##0)"
Next
End With
'Put Borders around the Data Area
With objXLws.Range(strLeftRange, strRightRange)
.Borders(xlTop).LineStyle = xlContinuous
.Borders(xlTop).Weight = xlThin
.Borders(xlBottom).LineStyle = xlContinuous
.Borders(xlBottom).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).Weight = xlThin
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).Weight = xlThin
End With
'Spreadsheet is complete - Save it
'Set up default path and file
strCurrYear = Me.txtCurrYear
strCurrMonth = Me.cboPeriod.Column(1)
strDefaultDir = "\\rsltx1-bm01\busmgmt\Vought " & strCurrYear & "\" &
strCurrYear _
& " Actuals\" & strCurrMonth & "\"
strDefaultFileName = Me.cboPeriod.Column(1) & _
IIf([Forms]![frmsccbrpt]![cboResource] = "SEL", _
" SCCB Report", " " & Me.cboResource & " Performance Report") &
".xls"
'Set filter to show only Excel spreadsheets
strFilter = ahtAddFilterItem(strFilter, "Excel Files (*.xls)")
'Flags Hides the Read Only Check and Only allow existing files
lngFlags = ahtOFN_HIDEREADONLY Or ahtOFN_OVERWRITEPROMPT
'Call the Open File Dialog
varGetFileName = ahtCommonFileOpenSave( _
OpenFile:=False, _
InitialDir:=strDefaultDir, _
Filter:=strFilter, _
Filename:=strDefaultFileName, _
Flags:=lngFlags, _
DialogTitle:="Save Report")
If varGetFileName <> "" Then
objXLWkb.SaveAs Filename:=varGetFileName
Select Case strOutPut
Case "Print"
blnStopXl = True
objXLws.PrintOut Copies:=1, Collate:=True
Case "PreView"
blnStopXl = True
ObjXLApp.DisplayAlerts = True
ObjXLApp.Interactive = True
ObjXLApp.ScreenUpdating = True
ObjXLApp.Visible = True
ObjXLApp.WindowState = xlMaximized
objXLws.PrintPreview
ObjXLApp.Visible = False
Case "XL"
blnStopXl = False
ObjXLApp.DisplayAlerts = True
ObjXLApp.Interactive = True
ObjXLApp.ScreenUpdating = True
ObjXLApp.WindowState = xlMaximized
ObjXLApp.Visible = True
End Select
End If
'Time to Go
Build_XL_Report_Exit:
Me.txtStatus.Visible = False
Me.Repaint
If blnStopXl Then
objXLWkb.Close
If blnExcelWasNotRunning = True Then
ObjXLApp.Quit
Else
ObjXLApp.DisplayAlerts = True
ObjXLApp.Interactive = True
ObjXLApp.ScreenUpdating = True
End If
Set objXLws = Nothing
Set objXLWkb = Nothing
Set ObjXLApp = Nothing
End If
DoCmd.Hourglass (False)
Exit Sub
Build_XL_Report_ERR:
MsgBox (Err.Number & " - " & Err.Description)
blnStopXl = True
GoTo Build_XL_Report_Exit
End Sub
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- - - - - - - - - - - - -
Very nice code, Klatuu, I'm sure you have a declaration section
where you declare all the xlConstants, don't you? (probably also
contains declaration of "cell", too?)
Else there'd probably be some challenges going late bound.
--
Roy-Vidar
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- - - - - - - - - - - - -
No, it works as is. I have seen other posts stating the xl constants are
only available in late binding, but I have found that not to be true. In
fact, I can go into the immediate window without an instance of Excel
running
and query an xl constant and it returns the correct value. Maybe it could
be
because I have the Excel 11.0 object library in my references.
I use late binding because when this particular code was written, we had
some users on Office 2000 and some on 2003. Early binding in that case
causes one or the other not to work because the object libraries are
different.
As to the cells, I don't know what you mean. Cells is a property of both
the Worksheet and Range objects.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- - - - - - - - - - - - -
Yes!
The xlConstants are only available when referencing the automated
application, which is what one would do when using early binding.
Check out Tony Toews article on late binding, with further links
http://www.granite.ab.ca/access/latebinding.htm
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- - - - - - - - - - - - -
I went back and looked more closely at the cell issue. My brain, at first
read cells. Now looking at it, I wonder why it works. It has been in
production since March, 2005. That's weird. I don't even find any refernce
to a cell object or property in help or the object browser.
Well, maybe I discovered something. I promise it works.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- - - - - - - - - - - - -
I think you didn't use Option Explicit and the "cell" wasn't declared as
anything so the Range object is assigned to the variable "cell" in your For
Each statement.
You can check this fairly easily because if I am correct, the For Each ...
loop is only executed once only.
--
HTH
Van T. Dinh
MVP (Access)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- - - - - - - - - - - - -
Had a similar need just last week. You can open the spreadsheet and make
the format changes all from VBA. Here is my code, which works in A2K.
Maybe
you can take something from it.
Bruce
Sub SetSpreadsheetHeadings( _
forFilePath As String, _
Optional tabName As String)
On Error GoTo Proc_Err
'
' Sets headings for new spreadsheet.
'
Dim ObjXLApp As Excel.Application
Dim wb As Excel.Workbook
Dim bolLeaveOpen As Boolean
If IsMissing(tabName) Then tabName = ""
'If Excel is already open, use that instance
bolLeaveOpen = True
'Attempting to use something that is not available
' will generate an error.
On Error Resume Next
Set ObjXLApp = GetObject(, "Excel.Application")
Err.Clear
On Error GoTo Proc_Err
'If ObjXLApp is defined, then we already have a conversation open
If TypeName(ObjXLApp) = "Nothing" Then
bolLeaveOpen = False
'Excel was not open -- create a new instance
Set ObjXLApp = CreateObject("Excel.Application")
End If
'Keep any open workbooks from running any macros while I'm using it.
ObjXLApp.EnableEvents = False
'Open workbook just created.
Set wb = ObjXLApp.Workbooks.Open(forFilePath)
'Keep the workbook from running macros while I use it.
ObjXLApp.EnableEvents = False
'Rename tab.
wb.Worksheets("ExportTemp").Select
If tabName > "" Then
wb.Worksheets("ExportTemp").Name = tabName
Else
tabName = "ExportTemp"
End If
'Select headings row and format.
wb.Worksheets(tabName).Rows("1:1").Select
With ObjXLApp.Selection
.Font.FontStyle = "Bold"
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
With .Interior
.ColorIndex = 15
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
End With
'Set all columns to best width.
wb.Worksheets(tabName).Cells.Select
ObjXLApp.Selection.Columns.AutoFit
'Deselect heading row by selecting single cell.
wb.Worksheets(tabName).Range("A2").Select
'Save changes, then be sure they are saved before continuing.
wb.Save
DoEvents
'Close this specific workbook.
wb.Close False
'Turn macros back on for any workbooks still open.
ObjXLApp.EnableEvents = True
Proc_Exit:
On Error Resume Next
If TypeName(ObjXLApp) <> "Nothing" Then
If Not bolLeaveOpen Then ObjXLApp.Quit
End If
Set wb = Nothing
Set ObjXLApp = Nothing
Err.Clear
Exit Sub
Proc_Err:
MsgBox "Error editing spreadsheet:" & vbCr & vbCr & _
"Error Code: " & Err.Number & vbCr & _
Err.Description, vbOKCritical, "Error!"
Err.Clear
Resume Proc_Exit
End Sub
Nice code, Bruce.
I would make one suggestion. The Selection object in Automation can get
squirly on you. It is really better to use the Range object. It seems to be
more stable.
Klatuu
thanks for the tip on the Range vs. Selection. Didn't know that
shiro said:
I've read the code written by Mr Dev on the site but that is not excatly
understand how the code is work.I have condition:
Some data that I want to output to are on the form Header,and the others
are on the detail section of my continuous form.Below is where I've got so
far
Dim appXL As Object
Dim wkb As Object
Dim wks As Object
Set appXL = CreateObject("Excel.Application")
Set wkb = appXL.Workbooks.Open("C:\MyFolder\My Workbook.xls")
Set wks = wkb.Worksheets(1)
appXL.Visible = True
wks.Cells(4, 3) = [Customer]
wks.Cells(6, 3) = [LotNo]
wks.Cells(7, 3) = [Model]
Field 'Customer' and 'LotNo' are on the form header and 'Model' is on
the detail section of the form.And if there are about 5 records returned
after filtering.I want the field 'Model' outputting to cell (7, 3) until
cell (11, 3)
Does the 'Model' outputting with range? Please help to code it.
Thank's
