Can anyone explain why this code generates an error 438 every other time on the past line?
'Use this function to export a large table/query from your database to a new Excel workbook.
'You can also specify the name of the worksheet target.
'strSourceName is the name of the table/query you want to export to Excel.
'strWorkbookPath is the path of the workbook you want to export the data.
'strTargetSheetName is the desired name of the target sheet.
'By Christos Samaras
'http://www.myengineeringworld.net
'Set the desired recordset (table/query).
'Create a new Excel instance.
'Try to open the specified workbook.
'Write the headings in the target sheet.
'Copy the data in the target sheet.
rst.MoveFirst
The code crashes on the .copy line every other time.
I can see it selected the correct parts in the sheet both times.
'Close the recordset.
Code:
Function DataToExcel(strSourceName As String, Optional strWorkbookPath As String, Optional strTargetFileName As String, Optional strCallingForm As String)
'You can also specify the name of the worksheet target.
'strSourceName is the name of the table/query you want to export to Excel.
'strWorkbookPath is the path of the workbook you want to export the data.
'strTargetSheetName is the desired name of the target sheet.
'By Christos Samaras
'http://www.myengineeringworld.net
Code:
Dim rst As DAO.Recordset
Dim excelApp As Object
Dim Wbk As Object
Dim sht As Object
Dim fldHeadings As DAO.Field
Dim strTargetSheetName As String
strTargetSheetName = "AccessData"
Code:
Set rst = CurrentDb.OpenRecordset(strSourceName)
Code:
Set excelApp = CreateObject("Excel.Application")
On Error GoTo Errorhandler
Code:
Set Wbk = excelApp.Workbooks.Open(strWorkbookPath)
excelApp.Visible = True
Set sht = excelApp.ActiveWorkbook.Sheets(2)
sht.Activate
excelApp.ActiveWorkbook.SaveAs strTargetFileName
Code:
For Each fldHeadings In rst.Fields
excelApp.ActiveCell = fldHeadings.Name
excelApp.ActiveCell.Offset(0, 1).Select
Next
rst.MoveFirst
Code:
sht.Range("A2").CopyFromRecordset rst
sht.Range("1:1").Select
sht.Rows("2:2").Select
excelApp.ActiveWindow.FreezePanes = True
Set sht = excelApp.ActiveWorkbook.Sheets(1)
sht.Activate
Select Case strCallingForm
Case "frmOrderAdd"
sht.Range("B1:B26").Select
With Selection
[COLOR=red][B].Copy[/B][/COLOR]
[COLOR=black] .PasteSpecial Paste:=xlPasteValues[/COLOR]
End With
Case Else
sht.Cells.Select
With Selection
[COLOR=red][B] .Copy[/B][/COLOR]
[COLOR=red][/COLOR][COLOR=black].PasteSpecial Paste:=xlPasteValues[/COLOR]
End With
End Select
I can see it selected the correct parts in the sheet both times.
'Close the recordset.
Code:
rst.Close
Set rst = Nothing
excelApp.ActiveWorkbook.Sheets("AccessData").Delete
excelApp.ActiveWorkbook.Save
excelApp.Quit
Exit Function
Errorhandler:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Numb
Exit Function
End Function
Last edited: