Runtime error 1004 - Save method of workbook failed

[captdkl02]

I modified a Function SendTQ2XLWbSheet (access query results to existing excel workbook) in attempting to save Excel workbook and exiting out of Excel after the "CopyFromRecordset" was done. I made these changes when observing each time I called the function I saw it was not saving the file with changes to the workbook sheet and Excel was still open each time I called this function. After many calls to this function, I did not have any of the workbook changes saved and I many instances of Excel running.

At this time I am receiving a run time error 1004 - Save method of workbook failed. I want to save the excel workbook changes and close Excel each time I call this function.

Any suggestions is greatly appreciated. I am including the code for the function.

Thank you.

David

------ Code below

Public Function SendTQ2XLWbSheet(strTQName As String, strSheetName As String, strFilePath As String)
' strTQName is the name of the table or query you want to send to Excel
' strSheetName is the name of the sheet you want to send it to


' strFilePath is the name and path of the file you want to send this data into.


Dim rst As DAO.Recordset
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
Dim fld As DAO.Field

Dim strPath As String

Const xlCenter As Long = -4108
Const xlBottom As Long = -4107

' On Error GoTo err_handler



strPath = strFilePath


Set rst = CurrentDb.OpenRecordset(strTQName)



Set ApXL = CreateObject("Excel.Application")



Set xlWBk = ApXL.Workbooks.Open(strPath)


ApXL.Visible = False


Set xlWSh = xlWBk.Worksheets(strSheetName)

xlWSh.Activate

' x1WSh.Select


' xlWSh.Range("A1").Select


' For Each fld In rst.Fields
' ApXL.ActiveCell = fld.Name
' ApXL.ActiveCell.Offset(0, 1).Select
' Next


rst.MoveFirst

xlWSh.Range("A2").CopyFromRecordset rst


' xlWSh.Range("1:1").Select
' This is included to show some of what you can do about formatting. You can comment out or delete
' any of this that you don't want to use in your own export.
' With ApXL.Selection.Font
' .Name = "Arial"
' .Size = 12
' .Strikethrough = False
' .Superscript = False
' .Subscript = False
' .OutlineFont = False
' .Shadow = False


' End With


' ApXL.Selection.Font.Bold = True


' With ApXL.Selection
' .HorizontalAlignment = xlCenter
' .VerticalAlignment = xlBottom
' .WrapText = False
' .Orientation = 0
' .AddIndent = False
' .IndentLevel = 0
' .ShrinkToFit = False
' .MergeCells = False
' End With


' selects all of the cells
ApXL.ActiveSheet.Cells.Select


' does the "autofit" for all columns
ApXL.ActiveSheet.Cells.EntireColumn.AutoFit


' selects the first cell to unselect all cells
xlWSh.Range("A1").Select

'Save the Workbook and Quit Excel
For Each xlWBk In ApXL.Application.Workbooks
xlWBk.Save 'this is where the run time error is occuring
Next xlWBk
Application.Quit


' With xlWBk
' .SaveAs strPath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
' .Close SaveChanges:=False
' End With

ApXL.Quit


rst.Close


Set rst = Nothing


Exit_SendTQ2XLWbSheet:
Exit Function


err_handler:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_SendTQ2XLWbSheet
End Function

[June7]

Try:

xlWBk.Close savechanges:=True

[captdkl02]

June,

This work with no problem!! Thank you for your help and reply!!!