Link to home
Start Free TrialLog in
Avatar of Murray Brown
Murray BrownFlag for United Kingdom of Great Britain and Northern Ireland

asked on

Access VBA - Error when exporting to Excel


I am getting the following error when running the code below to export data. It happens at the line "  Worksheet.Range("A2").CopyFromRecordset CRecordset"
The spreadsheet is still created though Book1.xlsx

User generated image
Public Function ExcelExportAndFormat(ByVal CRecordset As DAO.Recordset, ByVal CSheetName As String) As Object

  On Error GoTo Error_Handler

  Dim Excel As Object ' Excel.Application
  Dim Workbook As Object ' Excel.Workbook
  Dim Worksheet As Object ' Excel.Worksheet
  Dim Count As Long
  Set ExcelExportAndFormat = Nothing
  Set Excel = CreateObject("Excel.Application")

  Set Workbook = Excel.Workbooks.Add
  Set Worksheet = Workbook.Sheets(1)
  Worksheet.Name = CSheetName
  For Count = 0 To CRecordset.Fields.Count - 1
    Worksheet.Range("A1").Offset(, Count).Value = CStr(CRecordset.Fields(Count).Name)
  Next Count
  '//NOTE: The following line is highly important to stop green error messages
  Excel.Application.ErrorCheckingOptions.NumberAsText = False '// stop number store as text error
  Worksheet.Range("A2").CopyFromRecordset CRecordset
  Worksheet.Rows(1).Font.Bold = True
  Excel.ActiveWindow.FreezePanes = True

  If blnExcelValidationsTable = True Then
      Excel.Cells.RowHeight = 15
      Excel.Columns("A:A").ColumnWidth = 3.89
      Excel.Columns("B:B").ColumnWidth = 74.89
      Excel.Columns("C:C").ColumnWidth = 74.89
      Excel.Columns("D:D").ColumnWidth = 27.89
      Excel.Columns("E:E").ColumnWidth = 69.89
      Excel.ActiveWindow.DisplayGridlines = True
      Excel.ActiveWindow.DisplayGridlines = False
      Excel.Rows("1:1").RowHeight = 21.6
  End If
  '// take care of green "numbers stored as text" error [This did not work!]
  ''Dim c As Variant
  ''Dim sUsedRange As String: sUsedRange = Worksheet.UsedRange.Address
  'MsgBox sUsedRange
  ''Worksheet.Activate 'Without this the next few lines don't work..
  ''For Each c In Worksheet.UsedRange.Cells
      ''c.Errors(xlNumberAsText).Ignore = True
    ''For Each c In Excel.ActiveSheet.UsedRange.Cells
       ''c.Errors(xlNumberAsText).Ignore = True

  Set ExcelExportAndFormat = Worksheet
  Excel.Visible = True
  Set Worksheet = Nothing
  Set Workbook = Nothing
  Set Excel = Nothing
    On Error Resume Next
    Excel.Visible = True
    If Not Worksheet Is Nothing Then Set Worksheet = Nothing
    If Not Workbook Is Nothing Then Set Workbook = Nothing
    If Not Excel Is Nothing Then Set Excel = Nothing
    Exit Function

      MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
                 "Error Number: " & Err.Number & vbCrLf & _
                 "Error Source: ExcelExportOnly" & vbCrLf & _
                 "Error Description: " & Err.Description & _
                 Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
                 , vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit

End Function

Open in new window

Avatar of Daniel Pineault
Daniel Pineault

Have you tried stepping through your code?
Does CRecodset have data?
As stated previously, you should name variables Excel, Worksheet, Workbook, ... these are reserved words in Excel.  This can lead to weird behaviors.  I don't know if that is the case here, but it would be the first thing I'd change before anything else.  Then ensure everything compiles without code before going further in troubleshooting.
copyfromrecordset fails with when memo fields contains over 255 characters or cells that contain errors like #error#

If that is your problem, perhaps the following will solve your problem. You might need to modify it some to work on your machine.
Also, I have marked several lines as "future code".
for instance AutofitBelowRow1  is nice. if you have a  Yes/No column it makes the column be 5 characters wide even if the column heading is "CustomerAcceptsBackorders"
  If you are interested I can also post that code.  

Sub getrecordset(rs As Object, rng As Range, Optional lngIncludeNames As Long = 0) ' 0 = no  1 = yes, 2 = name columns
' replaces Excel's  rng.getrecordset function, except this routine allows 
' both nulls and strings longer than 255 characters.
' (It still does not allow recordsetS with cells that contain "errors" like #ERROR#.
' This also works with very big recordsets without requiring excess amounts of storage.
' This also autofits the spreadsheet.
On Error GoTo err_routine
If rs.EOF Then
    MsgBox "record set is empty"
    Exit Sub
End If
Static Lvl As Long
Lvl = Lvl + 1
If Lvl > 1 Then Stop

Dim prev As Boolean
prev = Application.ScreenUpdating
Application.ScreenUpdating = False

Dim Offset As Long, i As Long, Field As Object
Select Case lngIncludeNames
Case 1
    i = 0
    For Each Field In rs.Fields
        rng.Cells(1, 1).Offset(0, i) = Field.Name
        i = i + 1
    Offset = Offset + 1
Case 2
    ' future code Call rsToColumnNames(rs, rng)
    Offset = Offset + 1
End Select

Do Until rs.EOF
'    Stop
    ARY = rs.GetRows(20)
    If UBound(ARY, 1) = -1 Then
        MsgBox "The query returned records that contained errors. Please have a programmer change the sql to eliminate the error." _
         & " (For instance, avoid division by zero as follows: Iif([Cmtd Discount]=0,0,[Total Authorized Disbursement]/[Cmtd Discount]*100)."
        Exit Do ' godrt 129486 originally show all years except fy2017. I have fixed the sql, so it no longer gives the error.
    End If
    ARY ="G.xla!transposearray", ARY) "g.xla!arraytocells", ARY, rng.Offset(Offset, 0)
    Offset = Offset + UBound(ARY, 1) + 1
rng.Resize(Offset, rs.Fields.Count).Name = "RecordSet"
' future code Call AutofitBelowRow1
' Stop
Application.ScreenUpdating = prev

Lvl = Lvl - 1
Exit Sub
 MsgBox Error$
    ' see DemoGoto0InMain/ if error can be handled and/or ignored code your desired logic followed by one of the following
    Resume exit_routine ' ignore error and leave subroutine
    Resume Next 'restarts after failing line
    Resume ' reexecute failing line
    ' if error cannot be handled, alert user (or log) then raise error in higher level
    If False Then 'Replace false with swUnattended when subroutine is running on a server
       ' Call WriteLogFile("exit main because:" & Err.Number & " " & Err.Description)
        MsgBox Err.Number & " " & Err.Description
    End If
End Sub

Open in new window

Avatar of ste5an
Flag of Germany image

Link to home
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Murray Brown


Thanks very much