Duane - thank you.
I can just type in the Header Fields above the transferred data. I transfer
a Start date (thru automation), so I can write formulas to show the Cross-tab
date values.
Here's the Subroutine w/ comments, etc.
Public Sub CopyData(strSql As String, strWorkBook As String, _
Optional strWorkSheet As String, Optional strCellRef As String, _
Optional SSS As String, Optional TTT As String, _
Optional DEF As String, Optional GHI As String)
Dim Z As Database
On Error GoTo ProcError
DoCmd.Hourglass True
Dim objXLApp As Object 'Excel.Application
Dim objXLWb As Object 'Excel.Workbook
Dim objXLSheet As Object 'Excel.Worksheet
Dim RS As DAO.Recordset, RT As DAO.Recordset
Dim AQQ As DAO.QueryDef, PM As DAO.Parameter
Dim fld As DAO.Field, I%, iSheets%
'set rs from sql, table or query
Set Z = CurrentDb
Set AQQ = Z.QueryDefs(strSql)
For Each PM In AQQ.Parameters
PM.Value = Eval(PM.Name)
Next PM
Set RS = AQQ.OpenRecordset(, dbOpenSnapshot)
'start Excel
Set objXLApp = CreateObject("Excel.Application")
'open workbook, error routine will create it if doesn't exist
'only create workbooks with 1 sheet
iSheets = objXLApp.SheetsInNewWorkbook 'save user's setting
objXLApp.SheetsInNewWorkbook = 1 'set for only 1 sheet
Set objXLWb = objXLApp.Workbooks.Open(strWorkBook)
objXLApp.SheetsInNewWorkbook = iSheets 'restore user's setting
'select a worksheet, if sheet doesn't exist
'the error routine will add it
If strWorkSheet = "" Then strWorkSheet = "Sheet1"
'If Range is missing default to A1
If strCellRef = "" Then strCellRef = "A1"
'select desired worksheet
Set objXLSheet = objXLWb.Worksheets(strWorkSheet)
objXLSheet.Range(SSS).Clear
objXLSheet.Range(SSS) = TTT
objXLSheet.Range(strCellRef).Clear 'Is "TheData"
objXLSheet.Range(strCellRef).CopyFromRecordset RS, 50000, 150
Outa:
objXLWb.Save: objXLWb.Close
'DoCmd.SetWarnings True
'close up other rs objects
If Not RS Is Nothing Then RS.Close: Set RS = Nothing
If Not AQQ Is Nothing Then AQQ.Close: Set AQQ = Nothing
If Not Z Is Nothing Then Z.Close: Set Z = Nothing
Set objXLSheet = Nothing: Set objXLWb = Nothing
'quit Excel
If Not objXLApp Is Nothing Then objXLApp.Quit: Set objXLApp = Nothing
'DoCmd.Hourglass False
Exit Sub
ProcError:
Select Case Err
Case -2147417851 '"The server threw an exception"
' Caused when objXLSheet.Range(strCellRef).CopyFromRecordset RS
'Instead of objXLSheet.Range(strCellRef).CopyFromRecordset RS, 100, 2
Case 9 'Worksheet doesn't exist
objXLWb.Worksheets.Add
Set objXLSheet = objXLWb.ActiveSheet
objXLSheet.Name = strWorkSheet
Resume Next
Case 1004 'Workbook doesn't exist, make it
objXLApp.Workbooks.Add
Set objXLWb = objXLApp.ActiveWorkbook
objXLWb.SaveAs strWorkBook
Resume Next
Case Else
DoCmd.Hourglass False
MsgBox Err.Number & " " & Err.Description
Resume '0
End Select
End Sub
TIA - Bob
