Having trouble exporting from Access to Excel

[Jesse Aviles]

I have a query that i want to export to an Excel table. It would have been very easy to use the
Export To... menu command, however, several columns are computed columns and the Excel files need to
have the formula set in those columns instead of the value. After reading the Help file, I have
tried using the following code:

Function SendDataToExcel(strSource As String, strDestination As String)
'---------------------------------------------------------------------------------------
' Procedure : SendDataToExcel
' DateTime : 2005-08-05 07:46
' Author : Jesse Avilés
' Purpose :
'---------------------------------------------------------------------------------------
'
Dim objExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim lngRowIndex As Long
Dim lngColIndex As Long
Dim rstADO As ADODB.Recordset
Dim fld As ADODB.Field

On Error GoTo ErrorHandler

Set objExcel = New Excel.Application
Set wkb = objExcel.Workbooks.Add
Set wks = wkb.Worksheets.Add
wks.Name = "rptConteo"

Set rstADO = New ADODB.Recordset

rstADO.Open strSource, CurrentProject.Connection, adOpenStatic, adLockPessimistic
'wks("rptConteo").Activate

While Not rstADO.EOF
For lngRowIndex = 1 To rstADO.RecordCount
lngColIndex = 0
For Each fld In rstADO.Fields
--> With wks.Range(lngRowIndex, lngColIndex) <--
Select Case fld.Name
Case "TotalLibro"
.Formula = "=" & wks.Cells(lngRowIndex, 3) & "*" &
wks.Cells(lngRowIndex, 4)
.NumberFormat = "Currency"
Case "TotalFisico"
.Formula = "=" & wks.Cells(lngRowIndex, 3) & "*" &
wks.Cells(lngRowIndex, 6)
.NumberFormat = "Currency"
Case "TotalDif"
.Formula = "=" & wks.Cells(lngRowIndex, 3) & "*" &
wks.Cells(lngRowIndex, 9)
.NumberFormat = "Currency"
Case Else
.Value = fld.Value
End Select
End With
lngColIndex = lngColIndex + 1
Next fld
rstADO.MoveNext
Next lngRowIndex
Wend

wkb.SaveAs strDestination

ExitHandler:
On Error Resume Next
wkb.Close False
objExcel.Quit
Set objExcel = Nothing
rstADO.Close
Set rstADO = Nothing
Exit Function

ErrorHandler:

MsgBox "Unexpected Error: " & Err.Number & vbNewLine & Err.Description & vbNewLine & "In
procedure SendDataToExcel of Module mdlExcel"
Resume ExitHandler
End Function

I get "Error 1004 - Application defined or object defined error" in the line marked with arrows (-->
<--). I dont know if I will get additionla errors along the way but at least now the line tha's
giving me a pain, is almost textually copied from Excel VBA Help files (I tried other variants from
the Help files and they all give the same error). Using Win XP Pro, Office XP, latest updates,
Excel library referenced. Thanks.

 

[Douglas J. Steele]

AFAIK, Excel cells start at 1, not 0. Try lngColIndex = 1 instead.

 

[Jesse Aviles]

Thought so to but to no avail. Still receive the same error. Excel VBA Help refers to the cell as
follows:
Worksheets("Sheet1").Cells(5, 3)
I have tried:
wkb.Worksheets("Sheet1").Range(lngRowIndex, lngColIndex) --> Returns Error 1004
Worksheets("Sheet1").Range(lngRowIndex, lngColIndex) --> Returns Error 1004
With wks("Sheet1").Range(lngRowIndex, lngColIndex) -->Returns Error 438 Object doesnt support
this property or method

Thanks for your help.

 

[MacDermott]

I notice that you have commented out the line which activates this
worksheet.
You might try reinstating that line, to see what it does...

Another approach you might take would be this:
Use Excel's CopyFromRecordset statement (I may have that name wrong) to
dump all of your basic data into the Excel sheet.
Once you have that working, open the resulting sheet in Excel
(manually), and record a macro to add the formulae you want.
That should give you a good idea of the syntax you'll need to add to the
Access code.

 

[Ken Snell [MVP]]

I believe you need the Cells reference inside the Range reference:

With wks.Range(wks.Cells(lngRowIndex, lngColIndex))

 

[Jesse Aviles]

This is the working code (twelve hours after I started working on it).

Option Compare Database
Option Explicit

Function SendDataToExcel(strSource As String, strDestination As String)
'---------------------------------------------------------------------------------------
' Procedure : SendDataToExcel
' DateTime : 2005-08-05 07:46
' Author : Jesse Avilés
' Purpose :
'---------------------------------------------------------------------------------------
'
Dim objExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strPrice As String
Dim strQty As String
Dim lngRowIndex As Long
Dim lngColIndex As Long
Dim rstADO As ADODB.Recordset
Dim fld As ADODB.Field

On Error GoTo ErrorHandler

Set objExcel = New Excel.Application
Set wkb = objExcel.Workbooks.Add

Set rstADO = New ADODB.Recordset

rstADO.Open strSource, CurrentProject.Connection, adOpenStatic, adLockPessimistic

Set wks = wkb.Worksheets("Sheet1")
wks.Select

While Not rstADO.EOF
For lngRowIndex = 1 To rstADO.RecordCount
lngColIndex = 1
For Each fld In rstADO.Fields
strPrice = "C" & lngRowIndex
Set rng = wks.Cells(lngRowIndex, lngColIndex)
With rng
Select Case fld.Name
Case "TotalLibro"
strQty = "D" & lngRowIndex
.Formula = "=" & strPrice & "*" & strQty
.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)"
Case "TotalFisico"
strQty = "F" & lngRowIndex
.Formula = "=" & strPrice & "*" & strQty
.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)"
Case "TotalDif"
strQty = "H" & lngRowIndex
.Formula = "=" & strPrice & "*" & strQty
.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)"
Case Else
.Value = fld.Value
End Select
End With
lngColIndex = lngColIndex + 1
Next fld
rstADO.MoveNext
Next lngRowIndex
Wend

wkb.SaveAs strDestination

ExitHandler:
On Error Resume Next
wkb.Close False
objExcel.Quit
Set objExcel = Nothing
rstADO.Close
Set rstADO = Nothing
Exit Function

ErrorHandler:

MsgBox "Unexpected Error: " & Err.Number & vbNewLine & Err.Description & vbNewLine & "In
procedure SendDataToExcel of Module mdlExcel"
Resume ExitHandler
End Function

Thanks for your help. Hope this helps somebody.