Problem moving data from Access to Excel

J

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

Debra Dalgleish

VBA Help used Cells, and you used Range.

If you change to Cells, it should work.
 
J

Jesse Aviles

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

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


Jesse Aviles said:
Overlooked that, thanks! Now the code is breaking when I try to set the cell's formula. I get
Error 1004.
Click to expand...
 
D

Debra Dalgleish

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

Jesse said:
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.
Click to expand...
 
J

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.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Having trouble exporting from Access to Excel 5
Use range to move data between worksheets 2
Excel VBA 1
VBA with excel worksheets? 4
Error In Excel 2003 -"Runtime Error 1004: Select method of Range class failed" 1
Worksheet_Change Event 0
Excel VBA help: Text file formatting 19
Worksheet Sharing VBA 3

Top