Lots of code (appropriate snips)..
Private Sub cmdGoChart_Click(
Dim Z As Database, RS As DAO.Recordset, AQQ As DAO.QueryDe
Dim PM As DAO.Parameter, M$, N$, Q$, File
Dim objXLApp As Object 'Excel.Ap
Dim objXLWb As Object 'Excel.Workboo
Dim objXLSheet As Object 'Excel.Workshee
On Error GoTo AAA
...
Select Case cboMgm
Case "Mgr
File = "C:\BobDev\PDMgr.XLS
End Selec
...
Q = "SELECT RecDate, Round(Avg(TotPts),1) AS ThePts"
& " FROM RScores GROUP BY RecDate, AGroup"
& " HAVING RecDate <= #" & cboChartDate & "# AND"
& " AGroup = """ & cboMgmt & """;
N = "DataSheet
Call CopyTheData(Q, File, N, "TheData"
'Save wb, close up other rs objects, & quit Excel - Done in "CopyTheData
DoCmd.Hourglass Fals
If bLock = True The
bLock = Fals
Els
M = "The File " & File & vbCrL
M = M & "For " & cboMgmt & " Has Been Updated.": MsgBox M, , "
End I
AAA2
Call ShowHide
Exit Su
AAA1
Select Case Er
Case Els
MsgBox "Error Number " & Err.Number & " " & Err.DESCRIPTION: Resume AAA
End Selec
End Su
More..
Public Sub CopyTheData(strSql As String, strWorkBook As String,
Optional strWorkSheet As String, Optional strCellRef As String
On Error GoTo ProcErro
DoCmd.Hourglass True: bLock = Fals
Dim objXLApp As Object 'Excel.Applicatio
Dim objXLWb As Object 'Excel.Workboo
Dim objXLSheet As Object 'Excel.Workshee
Dim RS As DAO.Recordset, RT As DAO.Recordse
Dim fld As DAO.Field, I%, iSheets
'set rs from sql, table or quer
Set RS = CurrentDb.OpenRecordset(strSql, dbOpenSnapshot
'start Exce
Set objXLApp = CreateObject("Excel.Application"
'open workbook, error routine will create it if doesn't exis
'only create workbooks with 1 shee
iSheets = objXLApp.SheetsInNewWorkbook 'save user's settin
objXLApp.SheetsInNewWorkbook = 1 'set for only 1 shee
Set objXLWb = objXLApp.Workbooks.Open(strWorkBook
objXLApp.SheetsInNewWorkbook = iSheets 'restore user's settin
'select a worksheet, if sheet doesn't exis
'the error routine will add i
If strWorkSheet = "" The
strWorkSheet = "Sheet1
End I
'If Range is missing default to A
If strCellRef = "" Then strCellRef = "A1
'select desired workshee
Set objXLSheet = objXLWb.Worksheets("TheChart"
objXLSheet.Range("ATitle").Clea
objXLSheet.Range("ATitle") = Forms!frmMain!cboMgmt
& " For W/E (Saturday) " & Forms!frmMain!cboChartDat
objXLSheet.Range("Person").Clea
objXLSheet.Range("Person") = Forms!frmMain!cboMgmt.Column(1
'=
Set objXLSheet = objXLWb.Worksheets(strWorkSheet
objXLSheet.Range(strCellRef).Clear 'Is "TheData
objXLSheet.Range(strCellRef).CopyFromRecordset R
Set objXLSheet = objXLWb.Worksheets("TheChart"
'Save w
'DoCmd.SetWarnings Fals
Outa
objXLWb.Save: objXLWb.Clos
'DoCmd.SetWarnings Tru
'close up other rs object
If Not RS Is Nothing Then RS.Clos
Set RS = Nothin
Set objXLSheet = Nothin
Set objXLWb = Nothin
'quit Exce
If Not objXLApp Is Nothing Then objXLApp.Qui
Set objXLApp = Nothin
'DoCmd.Hourglass Fals
Exit Su
ProcError
Select Case Er
Case -2147417851 '"The server threw an exception
Case 9 'Worksheet doesn't exis
objXLWb.Worksheets.Ad
Set objXLSheet = objXLWb.ActiveShee
objXLSheet.Name = strWorkShee
Resume Nex
Case 1004 'Workbook doesn't exist, make i
objXLApp.Workbooks.Ad
Set objXLWb = objXLApp.ActiveWorkboo
objXLWb.SaveAs strWorkBoo
Resume Nex
Case Els
DoCmd.Hourglass Fals
MsgBox Err.Number & " " & Err.DESCRIPTIO
Sto
Resume
End Selec
End Su
