Problem moving data from Access to Excel

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

 

[Debra Dalgleish]

VBA Help used Cells, and you used Range.

If you change to Cells, it should work.

 

[Jesse Aviles]

Overlooked that, thanks! Now the code is breaking when I try to set the cell's formula. I get
Error 1004.

 

[Jesse Aviles]

This is the working code:

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.
--
Jesse Avilés
(e-mail address removed)

Reply Only To The Newsgroup

Overlooked that, thanks! Now the code is breaking when I try to set the cell's formula. I get
Error 1004.

 

[Debra Dalgleish]

I'm glad you've got it working, and thanks for posting your final code.

This is the working code:

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.

 

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