Sending data from Excel to Access

[bpascal123]

Hi cyberspace,

I'm still in the process of learning excel and access. I'd like to send data from excel 2003 to access 2003. I have found in the Excel forum a few discussions similar to this one although the code looks like what I'm posting, I'd like my code to run from Excel. What I have found here was a code that would run from Access :

access-programmers.co.uk/forums/showthread.php?t=211039&highlight=send+data+from+excel+to+access

So, I have downloaded an access template on the msdn site and i'm using this to learn. So far, I'm able to retrieve data from Access and SQL Server Denali through sql queries. I'm using Microsoft Active X data objects 6.0 library.

I don't know what's wrong but nothing happens when making this code run...

Option Explicit

Sub Send2Access()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim r As Long

Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset

cn.Open "Provider=Microsoft.jet.OLEDB.4.0;data source =
G:\code_access\access templates\PurchaseOrders.mdb;"

rs.Open "Suppliers", cn, adOpenKeyset, adLockOptimistic, adCmdTable
r = 2

Do While Len(Range("A" & r).Formula) > 0
With rs
.AddNew
.Fields("ContactTitle") = Range("A" & r).Value
.Fields("Address City") = Range("A" & r).Value
.Fields("PostalCode") = Range("A" & r).Value
.Fields("StateOrProvince") = Range("A" & r).Value
.Fields("Country") = Range("A" & r).Value
.Fields("PhoneNumber") = Range("A" & r).Value
.Fields("FaxNumber") = Range("A" & r).Value
.Fields("PaymentTerms") = Range("A" & r).Value
.Fields("EmailAddress") = Range("A" & r).Value
.Fields("Notes") = Range("A" & r).Value
.Update
End With

r = r + 1

Loop

rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub


Hope to get some help for this
cyberuser Pascal

 

[r.harrison]

Hi,

In your do ... loop you are adding data to different fields, but using the same excel cell (A & r).

This will make every field in the table the same.

 

[bpascal123]

Hi,

In your do ... loop you are adding data to different fields, but using the same excel cell (A & r).

This will make every field in the table the same.

Hi,

I've changed the code and now it's working half way. The data is being sent. However, I think there are a few issues about incrementation in my loop because the data is not sent in the right place.

Second thing, the code deletes all other tables in the db but the suppliers table that I want to update.

I wonder if this issue has something to do with the following instruction : .AddNew
.Update

Please find the code below:

Option Explicit

Sub Send2Access()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Cust2Suppliers")

Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim lig As Long, col As Long
Dim limLig As Long, limCol As Long

limLig = ws.Cells(Rows.Count, 2).End(xlUp).Row
limCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column

Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset

cn.Open "Provider=Microsoft.jet.OLEDB.4.0;data source = G:\code_access\access templates\PurchaseOrders.mdb;"

rs.Open "Suppliers", cn, adOpenKeyset, adLockOptimistic, adCmdTable
lig = 2
col = 2

For lig = 2 To limLig
With rs
.AddNew
.Fields("SupplierName") = ws.Cells(lig, col).Value
.Fields("ContactTitle") = ws.Cells(lig, col).Offset(0, 1).Value
.Fields("Address") = ws.Cells(lig, col).Offset(0, 1).Value
.Fields("City") = ws.Cells(lig, col).Offset(0, 1).Value
.Fields("PostalCode") = ws.Cells(lig, col).Offset(0, 1).Value
.Fields("StateOrProvince") = ws.Cells(lig, col).Offset(0, 1).Value
.Fields("Country") = ws.Cells(lig, col).Offset(0, 1).Value
.Fields("PhoneNumber") = ws.Cells(lig, col).Offset(0, 1).Value
.Fields("FaxNumber") = ws.Cells(lig, col).Offset(0, 1).Value
.Fields("PaymentTerms") = ws.Cells(lig, col).Offset(0, 1).Value
.Fields("EmailAddress") = ws.Cells(lig, col).Offset(0, 1).Value
.Fields("Notes") = ws.Cells(lig, col).Offset(0, 1).Value
.Update

End With

Next lig

rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Thanks for your help,
Pascal

 

[bpascal123]

Hi there,

Below is the code I looked at tonight. I have to say again I'm learning Vba for Excel, Access and Word and Outlook as well. It will be tough to be good at something when learning so much...

The code below is working like a charm. However for the lines near the end : "rs.Close Set rs = Nothing cn.Close Set cn = Nothing I get a run time error :

run-time error '3219':

Operation is not allowed in this context.

What does it mean? It's the same message if the access file is closed as well as if it's openned.

I'd just like to understand from any expert around.

Thanks,
Pascal


Option Explicit

Sub Send2Access2()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Cust2Suppliers")

Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset

cn.Open "Provider=Microsoft.jet.OLEDB.4.0; data source = G:\code_access\access templates\PurchaseOrders2.mdb;"

Dim lig As Long, col As Long
Dim limLig As Long, limCol As Long

limLig = ws.Cells(Rows.Count, 1).End(xlUp).Row
limCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column

rs.Open "Suppliers", cn, adOpenKeyset, adLockOptimistic, adCmdTable

col = 1

For lig = 2 To limLig + 1
With rs
.AddNew
.Fields("SupplierName") = ws.Cells(lig, col).Value
.Fields("ContactName") = ws.Cells(lig, col).Offset(0, 1).Value
.Fields("ContactTitle") = ws.Cells(lig, col).Offset(0, 2).Value
.Fields("Address") = ws.Cells(lig, col).Offset(0, 3).Value
.Fields("City") = ws.Cells(lig, col).Offset(0, 4).Value
.Fields("PostalCode") = ws.Cells(lig, col).Offset(0, 5).Value
.Fields("StateOrProvince") = ws.Cells(lig, col).Offset(0, 6).Value
.Fields("Country") = ws.Cells(lig, col).Offset(0, 7).Value
.Fields("Phonenumber") = ws.Cells(lig, col).Offset(0, 8).Value
.Fields("FaxNumber") = ws.Cells(lig, col).Offset(0, 9).Value
.Fields("PaymentTerms") = ws.Cells(lig, col).Offset(0, 10).Value
.Fields("EmailAddress") = ws.Cells(lig, col).Offset(0, 11).Value
.Fields("Notes") = ws.Cells(lig, col).Offset(0, 12).Value

End With
Next lig

rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

End Sub