export to existing excell sheet

[Notedop]

Hi,

I pulled below code from the internet to export an access sql output (recordset) to specified existing excel sheet. If you run the code once, it works. However a second time it will not work.

When I then 'physically' open the excell file, save and close it, it seems that the code works again but only once.

Error code is as following:

---------------------------
Microsoft Office Access
---------------------------
-2147417851 Method 'CopyFromRecordset' of object 'Range' failed
---------------------------
OK
---------------------------


the function call code:

Dim sql As String
sql = "select Imported_Open_data.[Master Case Number], Imported_Open_data.[SR Type], Imported_Open_data.[Case Category], " _
    & " Imported_Open_data.Priority, Imported_Open_data.Subject, Imported_Open_data.[Case Owner], Imported_Open_data.WorkGroup, " _
    & " Imported_Open_data.Status, Imported_Open_data.[First Touch Cycle Time], Imported_Open_data.[Age (Hours)]," _
    & " Imported_Open_data.[Case Age (Hrs)], Imported_Open_data.[Current SR Aging], Imported_Open_data.[Date/Time Opened], " _
    & " Imported_Open_data.[Case First Assignment Date], Imported_Open_data.[Case Open Time], Imported_Open_data.[Requeue Cycle Time Start], " _
    & " Imported_Open_data.[Date/Time Closed], Imported_Open_data.Weekend, Imported_Open_data.[Case Date/Time Last Modified], " _
    & " Switch([Case Date/Time Last Modified]<=(Now()-" & Forms!main_form!last_touch & " ),'Requires Touch' & [case owner],[Case Date/Time Last Modified]>(Now()-" & Forms!main_form!last_touch & " ),'Does not require touch' & [case owner]) AS [Require touch], " _
    & " Switch([Age (Hours)] > 480, 'Outlier' & [case owner], [Age (Hours)] > " & Forms!main_form!dangerzone & " And [Age (Hours)] < 480, 'Dangerzone' & [case owner]) As [Aging bucket]" _
    & " FROM Imported_Open_data;"
 
 
CopyRs2Sheet sql, CurrentProject.Path & "\pending cases report.xls", "data", "A2"

And the function:

Public Function CopyRs2Sheet(strsql As String, strWorkBook As String, Optional strWorkSheet As String, Optional strCellRef As String) As Boolean
'Uses the Excel CopyFromRecordset method
'strSql: Sql Select string
'strWorkBook: Full path and name to target wb, will create if doesn't exist
'strWorkSheet: Name of target worksheet, will create if doesn't exist
'strCellRef: Upper Left cell for data, defaults to A1
 
On Error GoTo ProcError
DoCmd.Hourglass True
'using late binding on Excel
Dim objXLApp As Object 'Excel.Application
Dim objXLWb As Object 'Excel.Workbook
Dim objXLSheet As Object 'Excel.Worksheet
Dim RS As DAO.Recordset
Dim fld As DAO.Field
Dim i As Integer
Dim iSheets As Integer
 
'set rs from sql, table or query
Set RS = CurrentDb.OpenRecordset(strsql, 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"
End If
 
'If Range is missing default to A1
If strCellRef = "" Then
strCellRef = "A1"
End If
 
'select desired worksheet
Set objXLSheet = objXLWb.Worksheets(strWorkSheet)
'clear the sheet from old data
objXLSheet.Range("A2:Z65000").Clear
 
'insert recordset into Excel Worksheet using CopyFromRecordset method
objXLSheet.Range(strCellRef).CopyFromRecordset RS
objXLSheet.Columns.AutoFit
 
'Save wb
objXLWb.Sheets("Dashboard").Activate
objXLWb.Save
objXLWb.Close
 
'close up other rs objects
If Not RS Is Nothing Then RS.Close
Set RS = Nothing
 
Set objXLSheet = Nothing
Set objXLWb = Nothing
 
'quit Excel
If Not objXLApp Is Nothing Then objXLApp.Quit
Set objXLApp = Nothing
 
DoCmd.Hourglass False
CopyRs2Sheet = True
Exit Function
 
ProcError:
Select Case Err
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
CopyRs2Sheet = False
Stop
Resume 0
End Select
 
End Function