Updating a 2003 Template to a 2010 Template - Existing Macro -Export Data to Access Gives errors

[JGARDNER-AIT]

Hello - here is our current code to export excel data to a msaccess database using a 2003 converted to 2010 template. Works as designed in 2003, first attempt in 2010 gived the error below.

References selected by deafult when converted:
Visual Basic For applications
Microsoft Excel 14.0 Object Library
OLE Automation
Microsoft Forms 2.0 Object Library
Microsoft Office 14.0 Object Library
Microsoft Outlook 14.0 Object Library
Microsoft Office Web Components 11.0
Microsoft Data Access Components Installed Version
Microsoft Access 14.0 Object Library
Microsoft DAO 3.6 Object library

Anyones help will be greatly appreciated. I have a bunch of users down.

******************************************************************
Im getting a ActiveX component cant create object Run-Time Error 429.


Sub ExportRFQToAccess()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim db As Database, rs As Recordset, r As Long
Set db = OpenDatabase("Y:\Quoting\Archive\Quote Templates\Quote Archive.mdb") <<<<-Debug Errors Here
' open the database
Set rs = db.OpenRecordset("Archive", dbOpenTable)
' get all records in a table
r = 11 ' the start row in the worksheet
Do While Len(Range("F" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("BOMORDR") = Range("B" & r).Value
.Fields("BOMLVL") = Range("C" & r).Value
.Fields("PARENT") = Range("D" & r).Value
.Fields("PART") = Range("F" & r).Value
.Fields("REV") = Range("G" & r).Value
.Fields("DESCRIPTION") = Range("H" & r).Value
.Fields("MFG#") = Range("I" & r).Value
.Fields("MFG") = Range("J" & r).Value
.Fields("VEN") = Range("K" & r).Value
.Fields("BOMQTYEA") = Range("L" & r).Value
.Fields("BOMQTYEAEXT") = Range("M" & r).Value
.Fields("UOMEA") = Range("N" & r).Value
.Fields("PAKQTY") = Range("O" & r).Value
.Fields("MINQTY") = Range("P" & r).Value
.Fields("MULTQTY") = Range("Q" & r).Value
.Fields("BOMUOM") = Range("R" & r).Value
.Fields("COSTCONV") = Range("S" & r).Value
.Fields("BOMQTY") = Range("T" & r).Value
.Fields("COMMODITY") = Range("U" & r).Value
.Fields("BREAK1") = Range("w" & r).Value
.Fields("COST1") = Range("x" & r).Value
.Fields("BREAK2") = Range("z" & r).Value
.Fields("COST2") = Range("aa" & r).Value
.Fields("BREAK3") = Range("ac" & r).Value
.Fields("COST3") = Range("ad" & r).Value
.Fields("BREAK4") = Range("af" & r).Value
.Fields("COST4") = Range("ag" & r).Value
.Fields("BREAK5") = Range("ai" & r).Value
.Fields("COST5") = Range("aj" & r).Value
.Fields("BREAK6") = Range("al" & r).Value
.Fields("COST6") = Range("am" & r).Value
.Fields("BREAK7") = Range("ao" & r).Value
.Fields("COST7") = Range("ap" & r).Value
.Fields("BREAK8") = Range("ar" & r).Value
.Fields("COST8") = Range("as" & r).Value
.Fields("BREAK9") = Range("au" & r).Value
.Fields("COST9") = Range("av" & r).Value
.Fields("BREAK10") = Range("ax" & r).Value
.Fields("COST10") = Range("ay" & r).Value
.Fields("STKPURLTQTY") = Range("ba" & r).Value
.Fields("STDPURLT") = Range("bb" & r).Value
.Fields("RCVDQTEDTE") = Range("bc" & r).Value
.Fields("EXPQTEDTE") = Range("bc" & r).Value
.Fields("VENQTE#") = Range("be" & r).Value
.Fields("NCNR") = Range("bf" & r).Value
.Fields("NREPROG") = Range("bg" & r).Value
.Fields("NREFIX") = Range("bh" & r).Value
.Fields("NRETOOL") = Range("bi" & r).Value
.Fields("NREARTWORK") = Range("bj" & r).Value
.Fields("NREINSPECT") = Range("bk" & r).Value
.Fields("FAIRREQ") = Range("bl" & r).Value
.Fields("FAIRCOST") = Range("bm" & r).Value
.Fields("NRENOTES") = Range("bn" & r).Value
.Fields("NRENOTES2") = Range("bo" & r).Value
.Fields("ADDITIONALFRGHT") = Range("bp" & r).Value
.Fields("QTEREF") = Range("bu" & r).Value


' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing

Range("H1").Select
ActiveCell.FormulaR1C1 = "EXPORTED BY: "
Range("I1").Select
ActiveCell.FormulaR1C1 = "REVIEWED BY: "
Range("H1:I1").Select
With Selection.Interior
.ColorIndex = 4
.Pattern = xlSolid
End With
Selection.Font.Bold = False
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("H1").Select
End Sub

 

[Trevor G]

Have you converted the database to Access 2010 if so the extension will have changed to accdb, also if references set for DAO what if you use the DAO command.

Dim db As DAO.Database
Dim rst As DAO.Recordset

 

[JGARDNER-AIT]

Have you converted the database to Access 2010 if so the extension will have changed to accdb, also if references set for DAO what if you use the DAO command.

Dim db As DAO.Database
Dim rst As DAO.Recordset

Hello Trevor, thank you for the reply. I'm a basic user when using VBA. But I was able to change the values above, and it still errors out with the same errors. Also, the access database is still 2003 at this time. This works perfect in 2003 environment, I need help what needs to be updated to get it to work on 2010 office. if I need to change the 2003 Access db to 2010, I can test that. Just need to make sure thats a good path to. If I need to send this file, I can. Let me know which email address.

Thank you for your help!
Josh

 

[Trevor G]

Josh does the database reside on a Server? if that might be the problem for the path. Also look at this code I use from time to time to see if adapting it may help, failing that then send me a private message

Sub AddToMDB()

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim r As Long

Set db = OpenDatabase("M:\Access Files\SampleDb.mdb")
Set rs = db.OpenRecordset("tblExcelImport", dbOpenDynaset)
r = 2
Do While Len(Range("A" & r).Formula) > 0

rs.AddNew
rs![FieldName1] = Range("A" & r).Value
rs![FieldName2] = Range("B" & r).Value
rs![FieldName3] = Range("C" & r).Value
rs![FieldName4] = Range("D" & r).Value
rs![FieldName5] = Range("E" & r).Value
rs![FieldName6] = Range("F" & r).Value
rs![FieldName7] = Range("G" & r).Value

rs.Update

r = r + 1
Loop
Set db = Nothing
Set rs = Nothing
MsgBox "Transfer Completed"

End Sub