Yes, you can use TransferSpreadsheet on existing files.
Automation: Ok, you asked for it, so here goes.
First, you will want to always use Late Binding. That is, rather than
typing your object variables as Excel objects, type them just as a generic
object:
Dim xlApp As Object 'Application Object
Dim xlBook As Object 'Workbook Object
Dim xlSheet As Object 'Worksheet Object
With Early Binding, you get a little speed advantage when creating the
object, but the problem with Early Binding is it binds to the verison of
Excel installed on the computer where you are doing the development. If the
user doesn't have the same version or updates to a newer version, it will
cause errors that will not allow your code to work at all. With late
binding, it doesn't load the version until the code runs, so it uses the
verion installed on the computer running the code.
The most important thing to keep in mind when using automation with Excel is
to fully qualify all your object references. If you use an ambiguous
reference, Access will not know what it belongs to, so it can actually create
an additional instance of Excel to use. Then when you quit the Excel
instance, it will shut down one instance but leave another running. The
symptom is that if you try to open Excel after this happens, it will hang and
never fully load. If you try to run your automation code again, it will not
work correctly. You can find it in the Processes tab of Task Manager as
EXCEL.EXE. So be aware of that.
Now, some users may have Excel already open, so you want to check for that
before you create a new instance. You also don't want to kill the instance
they have running when you are done, so you need to be aware of that and use
the CreateObject when there is not an instance of Excel running and the
GetObject if there is. You can do that with this code. Put the code in a
standard module by itself. It include the necessary API routines and an
example of how to open a spreadsheet. The important part here is the
DetectExcel sub.
'**************************************************
Option Compare Database
Option Explicit
' Declare necessary API routines:
Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As Long) As Long
Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Sub GetExcel()
Dim MyXL As Object ' Variable to hold reference
' to Microsoft Excel.
Dim ExcelWasNotRunning As Boolean ' Flag for final release.
' Test to see if there is a copy of Microsoft Excel already running.
On Error Resume Next ' Defer error trapping.
' Getobject function called without the first argument returns a
' reference to an instance of the application. If the application isn't
' running, an error occurs.
Set MyXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then ExcelWasNotRunning = True
Err.Clear ' Clear Err object in case error occurred.
' Check for Microsoft Excel. If Microsoft Excel is running,
' enter it into the Running Object table.
DetectExcel
' Set the object variable to reference the file you want to see.
Set MyXL = GetObject("c:\vb4\MYTEST.XLS")
' Show Microsoft Excel through its Application property. Then
' show the actual window containing the file using the Windows
' collection of the MyXL object reference.
MyXL.Application.Visible = True
MyXL.Parent.Windows(1).Visible = True
' Do manipulations of your file here.
' ...
' If this copy of Microsoft Excel was not running when you
' started, close it using the Application property's Quit method.
' Note that when you try to quit Microsoft Excel, the
' title bar blinks and a message is displayed asking if you
' want to save any loaded files.
If ExcelWasNotRunning = True Then
MyXL.Application.Quit
End If
Set MyXL = Nothing ' Release reference to the
' application and spreadsheet.
End Sub
'**********************************************************
Here is the code for a report I produced in Excel. It is rather long, but
it has some good examples of a lot of different things you can do in Access
with Excel. It is rather long, so I hope it all comes through. If not, post
back with the last line that came through and I will sent the rest.
Notice I destroy the Excel objects in the Exit portion of the procedure and
that the error handler causes the Exit portion to execute. This helps assure
the Excel objects get destroyed so you don't end up leaving the Excel
instance running.
Good Luck!
'Set up the necessary objcts
On Error Resume Next ' Defer error trapping.
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
blnExcelWasNotRunning = True
Set xlApp = CreateObject("excel.application")
Else
DetectExcel
End If
Err.Clear ' Clear Err object in case error occurred.
On Error GoTo Build_XL_Report_ERR
xlApp.DisplayAlerts = False
xlApp.Interactive = False
xlApp.ScreenUpdating = False
Set xlBook = xlApp.Workbooks.Add
Me.txtStatus = "Building Workbook"
Me.Repaint
'Remove excess worksheets
Do While xlBook.Worksheets.Count > 1
xlApp.Worksheets(xlApp.Worksheets.Count).Delete
Loop
Set xlSheet = xlBook.ActiveSheet
'Build The Spreadsheet
'Build The Headers
Me.txtStatus = "Creating Headers"
Me.Repaint
strMonth = Left(Me.cboPeriod.Column(1), 3)
xlSheet.Name = Me.cboResource & " Hours " & strMonth & " YTD"
With xlSheet
.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 xlSheet
For Each cell In xlSheet.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
xlSheet.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 xlSheet
For Each cell In xlSheet.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))
xlSheet.Range(strLeftRange).MergeCells = True
Next intX
'Size the Blank Row
xlSheet.Rows(lngItmCount + 3).RowHeight = 30
'Format Header Area and put in formulas
With xlSheet
For intX = 2 To lngItmCount + 1
strLeftRange = "C" & Trim(str(intX))
strRightRange = "S" & Trim(str(intX))
For Each cell In xlSheet.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 xlSheet.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 xlSheet.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
xlSheet.Cells(intX, 1) = "Grand Total " & xlSheet.Cells(intX, 1)
Next intX
xlSheet.Cells(intX, 1) = "Grand Total " & _
Me.cboResource & " HOURS"
'Copy the Header Row to the top of the Data Area
xlSheet.Range("A1:S1").Copy _
Destination:=xlSheet.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)
xlSheet.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 xlSheet
.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(xlSheet.Cells(lngRowCount, 1), "Total")
If lngTotalPos = 0 Then 'Column S needs to be light yellow if not a
total row
xlSheet.Cells(lngRowCount, 5).Interior.Color = conLightYellow
xlSheet.Cells(lngRowCount, 6).Interior.Color = conLightYellow
Else
strCurrItm = Left(xlSheet.Cells(lngRowCount, 1), lngTotalPos - 2)
With xlSheet
.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
xlSheet.Range("A:S").Copy
xlSheet.Range("A:S").PasteSpecial (xlPasteValues)
xlSheet.Range("A:S").RemoveSubtotal
xlSheet.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 xlSheet.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 = xlApp.InchesToPoints(0)
.RightMargin = xlApp.InchesToPoints(0)
.TopMargin = xlApp.InchesToPoints(0.5)
.BottomMargin = xlApp.InchesToPoints(0.5)
.HeaderMargin = xlApp.InchesToPoints(0.25)
.FooterMargin = xlApp.InchesToPoints(0.25)
.PrintArea = strPrintArea
.PrintTitleRows = xlSheet.Rows(strTitleRows).Address
End With
'Format the Data Area
With xlSheet
strLeftRange = "A" & Trim(str(lngFirstDataRow))
strRightRange = "S" & Trim(str(lngLastDataRow))
For Each cell In xlSheet.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 xlSheet.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
xlBook.SaveAs Filename:=varGetFileName
Select Case strOutPut
Case "Print"
blnStopXl = True
xlSheet.PrintOut Copies:=1, Collate:=True
Case "PreView"
blnStopXl = True
xlApp.DisplayAlerts = True
xlApp.Interactive = True
xlApp.ScreenUpdating = True
xlApp.Visible = True
xlApp.WindowState = xlMaximized
xlSheet.PrintPreview
xlApp.Visible = False
Case "XL"
blnStopXl = False
xlApp.DisplayAlerts = True
xlApp.Interactive = True
xlApp.ScreenUpdating = True
xlApp.WindowState = xlMaximized
xlApp.Visible = True
End Select
End If
'Time to Go
Build_XL_Report_Exit:
Me.txtStatus.Visible = False
Me.Repaint
If blnStopXl Then
xlBook.Close
If blnExcelWasNotRunning = True Then
xlApp.Quit
Else
xlApp.DisplayAlerts = True
xlApp.Interactive = True
xlApp.ScreenUpdating = True
End If
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = 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
