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

Hi

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.Rows("2:2").Select
  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
  Else
      Worksheet.Cells.EntireColumn.AutoFit
      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
  ''Next
    ''For Each c In Excel.ActiveSheet.UsedRange.Cells
       ''c.Errors(xlNumberAsText).Ignore = True
    ''Next
  ''//

  Set ExcelExportAndFormat = Worksheet
  Excel.Visible = True
  Set Worksheet = Nothing
  Set Workbook = Nothing
  Set Excel = Nothing
  
Error_Handler_Exit:
    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
       
Error_Handler:

      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
'Stop
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 ARY
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
    Next
    Offset = Offset + 1
Case 2
    ' future code Call rsToColumnNames(rs, rng)
    Offset = Offset + 1
End Select

Do Until rs.EOF
    DoEvents
'    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 = Application.run("G.xla!transposearray", ARY)
    Application.run "g.xla!arraytocells", ARY, rng.Offset(Offset, 0)
    Offset = Offset + UBound(ARY, 1) + 1
Loop
rng.Resize(Offset, rs.Fields.Count).Name = "RecordSet"
' future code Call AutofitBelowRow1
' Stop
Application.ScreenUpdating = prev

exit_routine:
Lvl = Lvl - 1
Exit Sub
err_routine:
 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)
    Else
        MsgBox Err.Number & " " & Err.Description
    End If
End Sub


Open in new window

ASKER CERTIFIED SOLUTION
Avatar of ste5an
ste5an
Flag of Germany image

Link to home
membership
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

ASKER

Thanks very much