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
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
