Bob,
here is code I use to format an excel worksheet.
I have not exprienced problems with date formats using this code.
I first export the query to excel, save and close the workbook.
Then I use Application.FollowHyperlink to open the workbook and worksheet
for formatting.
Public Sub FormatXLReport(strPath As String, _
strFile As String, _
lngReportID As Long, _
strMakeActive As String)
'lngReportID identifies which report is being run
'strMakeActive name of worksheet to activate
On Error GoTo SubErr
pstrProc = "FormatXLReport"
pstrSubProc = "FormatXLReport"
Dim db As DAO.Database
Dim blnExcelExists As Boolean
Dim objXLApp As Object
Dim objActiveWkb As Object
Dim objXLWkb As Object
Dim objXLws As Object
Dim strWkbName As String
Dim strCriteria As String
Dim sngColumnWidth As Single 'width of column
Dim strRange As String 'used to set the print area
Dim intI As Integer 'loop counter
Dim lngColumnCount As Long
Dim lngAlignR As Long
'Const xlMaximized As Integer = -4137
Const xlLandscape = 2
Const xlRight = -4152
Const xlCentre = -4108
Const xlAutomatic = -4105
Const xlContinuous = 1
Const xlCellTypeLastCell = 11
Set db = DBEngine(0)(0)
'Open the raw data spreadsheet for formatiing
If fIsAppRunning("excel", False) Then 'yes it is running
' Get a reference to currently running Excel window
Set objXLApp = GetObject(, "Excel.Application")
blnExcelExists = True
Else
' Excel is not currently running so create a new instance
Set objXLApp = CreateObject("Excel.Application")
End If
'Hide warnings on the spreadsheet
objXLApp.DisplayAlerts = False
'prevent any excel macros from running
objXLApp.Interactive = False
'hide screen changes
objXLApp.ScreenUpdating = False
'Open a workbook
objXLApp.Workbooks.Open (strPath)
'point to the active workbook
Set objXLWkb = objXLApp.Workbooks(strFile)
'Debug.Print "active workbook: " & objXLWkb.Name
'activate the selected workbook
objXLWkb.Activate
'Debug.Print strMakeActive
'Debug.Print "active sheet: " & ObjXLApp.ActiveWorkbook.Worksheets(1)
'point to the wanted worksheet
Set objXLws = objXLApp.ActiveWorkbook.Worksheets(1)
'activate the selected worksheet
objXLws.Activate
'now format the report
'get the count of how many columns for this report
lngColumnCount = Nz(DMax("[ColumnNo]", "tlkpXLRptProps", "[ReportID] = "
& lngReportID), 0)
lngAlignR = Nz(DLookup("[AlignR]", "tlkpXLReport", "[ReportID] = " &
lngReportID), 0)
'Debug.Print lngAlignR
'if any columns with costs then right align them
If lngAlignR > 0 Then
With objXLws.Cells
.columns(lngAlignR).horizontalalignment = xlRight
'centre the heading for the column with costs
.Range(.Cells(1, lngAlignR), .Cells(1,
lngAlignR)).horizontalalignment = xlCentre
End With
End If
With objXLws.Cells
'do column headings
For intI = 1 To lngColumnCount
.Range(.Cells(1, intI), .Cells(1, intI)) = _
FindColumnTitle(lngColumnNo:=intI, lngReportNo:=lngReportID)
Next intI
'format the cells
.Font.Name = "Arial"
.Font.FontStyle = "Regular"
.Font.Size = 10
'bold the headings
.Rows("1:1").Font.Bold = True
.WrapText = True
'set heading cell colour to white (OutputTo colours them grey)
.Range(.Cells(1, 1), .Cells(1, lngColumnCount)).Interior.Color =
RGB(255, 255, 255) 'white
'Put Borders around all cells in the Data Area
.Range(.Cells(1, 1), .Cells(1,
1).SpecialCells(xlCellTypeLastCell)).Borders.LineStyle = xlContinuous
.Range(.Cells(1, 1), .Cells(1,
1).SpecialCells(xlCellTypeLastCell)).Borders.ColorIndex = xlAutomatic
'set the column width
For intI = 1 To lngColumnCount
.Range(.Cells(1, intI), .Cells(1, intI)).ColumnWidth = _
FindColumnWidth(lngColumnNo:=intI,
lngTemplateNo:=lngReportID)
Next intI
'auto fit row height
.Rows.AutoFit
strRange = .Range(.Cells(1, 1), .Cells(1,
1).SpecialCells(xlCellTypeLastCell)).Address
'Debug.Print strRange
End With
'now do page set up
With objXLws.PageSetup
.Orientation = xlLandscape
'If zoom property is False, the FitToPagesWide and FitToPagesTall
properties
'control how the worksheet is scaled
.Zoom = False
.FitToPagesTall = False
.FitToPagesWide = 1
' .CenterHeader = Me.txtCurrYear & " " & Me.cboResource _
' & " Hours " & strMonth & " YTD"
.CenterFooter = "&F"
' .CenterFooter = "&F" & " " & "&D"
.RightFooter = "&R Page &P of &N"
.LeftMargin = objXLApp.CentimetersToPoints(0.5)
.RightMargin = objXLApp.CentimetersToPoints(1.5)
.TopMargin = objXLApp.CentimetersToPoints(1#)
.BottomMargin = objXLApp.CentimetersToPoints(1#)
.HeaderMargin = objXLApp.CentimetersToPoints(0.7)
.FooterMargin = objXLApp.CentimetersToPoints(0.7)
.printarea = strRange
'Debug.Print .printarea
End With
'put focus back to first data cell
objXLws.Range("A2").Select
'Prevent Excel from prompting to save changes
objXLApp.ActiveWorkbook.Save
SubExit:
'turn on warnings on the spreadsheet
objXLApp.DisplayAlerts = True
'allow any excel macros from running
objXLApp.Interactive = True
'show screen changes
objXLApp.ScreenUpdating = True
'close the instance of Excel created by code
If Not blnExcelExists Then
objXLApp.Quit
End If
If Not objActiveWkb Is Nothing Then
Set objActiveWkb = Nothing
End If
If Not objXLApp Is Nothing Then
Set objXLApp = Nothing
End If
If Not db Is Nothing Then
Set db = Nothing
End If
DoCmd.Hourglass False
Exit Sub
SubErr:
Select Case Err.Number
Case 3010
MsgBox pmsg2 & strPath & pmsg3, vbInformation, pstrT
Case 70, 430
MsgBox pmsg4, vbInformation, pstrT
Case Else
Call fnFormErrHandler(pstrProc, pstrSubProc, pstrMdl, Err)
End Select
Resume SubExit
End Sub