Update an access table from Excel

[meb135]

I have the following code to add data to a an access table. The code works fine. Now i would like to modify this code to perform the following:

Loop through each row of data and see if the ID # already exists somewhere in the access table. if it does, update that record with the new data. If it doesn't exist, create a new record with the new data. then move on to the next row and perform the same.

Any help would really be appreciated.

Here's the code that works.

Sub AccessRecord()
Dim nc As ADODB.Connection, rs As ADODB.Recordset, r As Long
' connect to the Access database
Set nc = New ADODB.Connection
nc.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & "Data Source = \\S11ECFF\Project\db1.mdb;"
Set rs = New ADODB.Recordset
rs.Open "T1_Header", nc, adOpenKeyset, adLockOptimistic, adCmdTable
Sheets("HData").Select
Mycount = Worksheets("HData").Range("B1").CurrentRegion.Rows.Count
r = 1
For r = 1 To Mycount
If Cells(r, 2).Value <> Empty Then
With rs
.AddNew
.Fields("ID") = Range("A" & r).Value
.Fields("Case_No") = Range("B" & r).Value
.Fields("File_No") = Range("C" & r).Value
.Update
End With
End If
Next r
rs.Close
Set rs = Nothing
nc.Close
Set nc = Nothing
End Sub

 

[stapuff]

you could use something like

change the DBPath to where your database is located
change tblname to your table

and change sheet("action" to your sheet name.



Dim tblname As String
Dim r As Long
Dim rcell As Range
Dim col1, col2, col3, col4, col5, col6, col7, col8, col9, col10, col11, col12, col13, col14, col15, col16, col17, col18, col19, col20, col21 As Range
Dim cn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim mysql, cellcombo As String
Const DBPath = "S:\where\your db is\test.mdb"


Sub Button2_Click()

cellcombo = (ActiveCell.Offset(0, -1).Value & ActiveCell.Offset(0, 0).Value & ActiveCell.Offset(0, 1).Value)

With Sheets("Action")
col1 = Sheets("Action").Range("A2").Value
col2 = Sheets("Action").Range("B2").Value
col3 = "Combo"
col4 = Sheets("Action").Range("C2").Value
col5 = Sheets("Action").Range("D2").Value
col6 = Sheets("Action").Range("E2").Value
col7 = Sheets("Action").Range("F2").Value
col8 = Sheets("Action").Range("G2").Value
col9 = Sheets("Action").Range("H2").Value
col10 = Sheets("Action").Range("I2").Value
col11 = Sheets("Action").Range("J2").Value
col12 = Sheets("Action").Range("K2").Value
col13 = Sheets("Action").Range("L2").Value
col14 = Sheets("Action").Range("M2").Value
col15 = Sheets("Action").Range("N2").Value
col16 = Sheets("Action").Range("O2").Value
col17 = Sheets("Action").Range("P2").Value
col18 = Sheets("Action").Range("Q2").Value
col19 = Sheets("Action").Range("R2").Value
End With

tblname = "item_listing"

rs.CursorLocation = adUseClient

Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=" & DBPath

Set rs = New ADODB.Recordset
mysql = "SELECT * from " & tblname & " WHERE [Combo]=" & """" & cellcombo & "" & """"
rs.Open mysql, cn, adOpenStatic, adLockOptimistic, adCmdText

If rs.RecordCount > 1 Then
MsgBox "You have too many of the same record. Your record count is " & rs.RecordCount
Exit Sub
End If

With rs
.Fields(col1) = ActiveCell.Offset(0, -1).Value
.Fields(col2) = ActiveCell.Offset(0, 0).Value
.Fields(col3) = ActiveCell.Offset(0, -1).Value & ActiveCell.Offset(0, 0).Value & ActiveCell.Offset(0, 1).Value
.Fields(col4) = ActiveCell.Offset(0, 1).Value
.Fields(col5) = ActiveCell.Offset(0, 2).Value
.Fields(col6) = ActiveCell.Offset(0, 3).Value
.Fields(col7) = ActiveCell.Offset(0, 4).Value
.Fields(col8) = ActiveCell.Offset(0, 5).Value
.Fields(col9) = ActiveCell.Offset(0, 6).Value
.Fields(col10) = ActiveCell.Offset(0, 7).Value
.Fields(col11) = ActiveCell.Offset(0, 8).Value
.Fields(col12) = ActiveCell.Offset(0, 9).Value
.Fields(col13) = ActiveCell.Offset(0, 10).Value
.Fields(col14) = ActiveCell.Offset(0, 11).Value
.Fields(col15) = ActiveCell.Offset(0, 12).Value
.Fields(col16) = ActiveCell.Offset(0, 13).Value
.Fields(col17) = ActiveCell.Offset(0, 14).Value
.Fields(col18) = ActiveCell.Offset(0, 15).Value
.Fields(col19) = ActiveCell.Offset(0, 16).Value
.Update
End With

Set cn = Nothing
Set rs = Nothing

End Sub

 

[meb135]

thanks for the reply. But your suggestion is so different then the code i provided that i wouldn't even know where to start on modifying it to suit what i'm looking for.

Is there any possibility of adding to my code to make it work?

 

[baitmaster]

You should stay with the ADODB route you are already on, and use SQL in order to restrict the data being returned

Here is an example of some update code taken from one of my files. Its a bit specific to my need in places, but you should find amongst it the areas of code you are looking for

Read up on SQL to help with this task, some other discussions Ive had on this subject recently are found here http://www.mrexcel.com/forum/showthread.php?t=560445

Sub updateDatabase()
 
Dim dataSet As Range, cl As Range, changedCells As Range
Dim DBref As Long, DBfield As String, strMsgReport As String
Dim duplicatedAction As Boolean: duplicatedAction = False
Dim dataSubmitted As Boolean: dataSubmitted = False
Dim arrFieldsUpdated(), intFieldUpdateCount As Integer, x As Integer
 
resetGlobals
 
If lastReviewRow <= Range("headers").Rows.Count Then
    MsgBox "no data found for updating", vbCritical
    Exit Sub
End If
 
' set database objects
Dim rsDataSet As DAO.Recordset
Set dB = OpenDatabase(strDatabase)
Set rsDataSet = dB.OpenRecordset(strTBL_timesheets, dbOpenTable)
 
With shtReviewer
    Set dataSet = .Range(.Cells(Range("headers").Rows.Count + 1, 1), .Cells(lastReviewRow, lastReviewColumn))
End With
 
' identify changed cells; update database for those rows, including status, submitted by/time/date
On Error Resume Next
Set changedCells = dataSet.SpecialCells(xlCellTypeComments)
On Error GoTo 0
 
If Not changedCells Is Nothing Then
 
    With rsDataSet
 
        ' review each cell in turn and make changes
        For Each cl In changedCells
 
            ' get DB ref, and field name
            DBref = Cells(cl.Row, 1).Value
            DBfield = Cells(1, cl.Column).Value
 
            .MoveFirst
 
            Do While Not .EOF
                If !DBref = DBref Then
                    If !submittedDate = Cells(cl.Row, colDate).Value And !submittedTime = Cells(cl.Row, colTime).Value Then
 
                        ' records reference # of updated field
                        intFieldUpdateCount = intFieldUpdateCount + 1
                        ReDim Preserve arrFieldsUpdated(1 To intFieldUpdateCount)
                        arrFieldsUpdated(intFieldUpdateCount) = !DBref
 
                        .Edit
                        .Fields(DBfield) = cl
                        .Update
 
                        cl.Interior.ColorIndex = 0
                        cl.Comment.Delete
                        dataSubmitted = True
                    Else
                        duplicatedAction = True
                    End If
                End If
                .MoveNext
            Loop
        Next cl
 
        ' record new details of time / date field changed
        For Each cl In changedCells
            .MoveFirst
 
            Do While Not .EOF
                For x = LBound(arrFieldsUpdated) To UBound(arrFieldsUpdated)
                    If !DBref = arrFieldsUpdated(x) Then
                        .Edit
                        !Status = "updated"
                        !submittedBy = Environ("UserName")
                        !submittedDate = Date
                        !submittedTime = Time
                        .Update
                    End If
                Next x
                .MoveNext
            Loop
        Next cl
    End With
Else:
    MsgBox "no changes found"
End If
 
strMsgReport = IIf(dataSubmitted, "Updates have been submitted to the database" & vbCr & vbCr, "") & IIf(duplicatedAction, "Some updates could not be made, as these have been changed already. Please see data set, and compare with latest entries in database", "")
 
If strMsgReport <> "" Then MsgBox strMsgReport
 
End Sub

 

[stapuff]

this should do it all for you. goes down column A, looks to see if the ID is in your table...if it is updates the 3 fields with the spreadsheet data...if not adds a new row.


Dim tblname As String
Dim r As Long
Dim rcell As Range
Dim col1, col2, col3, col4 As Range
Dim cn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim mysql, myvalue As String
Const DBPath = "\\S11ECFF\Project\db1.mdb"
Const tblname = "T1_Header"

Sub Button2_Click()

Sheets("HData").Select
Mycount = Worksheets("HData").Range("A1").CurrentRegion.Rows.Count
r = 1
For r = 1 To Mycount

myvalue = Cells(r, 1).Value

' this would be your column headings in your worksheet. I assume your column headings are the same "name" as your database field names
With Sheets("HData")
col1 = Sheets("HData").Range("A2").Value
col2 = Sheets("HData").Range("B2").Value
col3 = Sheets("HData").Range("C2").Value
End With

rs.CursorLocation = adUseClient

Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=" & DBPath

Set rs = New ADODB.Recordset
mysql = "SELECT * from " & tblname & " WHERE [ID]=" & """" & myvalue & "" & """"
rs.Open mysql, cn, adOpenStatic, adLockOptimistic, adCmdText

With rs
If rs.RecordCount = 0 then
.addnew
end if
.Fields(col1) = ActiveCell.Offset(0, 0).Value
.Fields(col2) = ActiveCell.Offset(0, 1).Value
.Fields(col3) = ActiveCell.Offset(0, 2).Value
.Update
End With

next r

Set cn = Nothing
Set rs = Nothing

End Sub

 

[stapuff]

sorry pasted wrong code. I noticed it but I guess there is a time limit to fix it.
use this below. I tested it against 600 records...took about 1 second

Dim tblname As String
Dim r As Long
Dim col1, col2, col3, col4 As Range
Dim cn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim mysql, myvalue As String
Const DBPath = "\\S11ECFF\Project\db1.mdb"

Sub test()

Sheets("HData").Select

tblname = "T1_Header"

' this would be your column headings in your worksheet. I assume your column headings are the same "name" as your database field names
With Sheets("HData")
col1 = Sheets("HData").Range("A1").Value
col2 = Sheets("HData").Range("B1").Value
col3 = Sheets("HData").Range("C1").Value
End With

rs.CursorLocation = adUseClient

Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=" & DBPath

Mycount = Worksheets("HData").Range("A1").CurrentRegion.Rows.Count
r = 2
For r = 2 To Mycount
myvalue = Cells(r, 2).Value


Set rs = New ADODB.Recordset
mysql = "SELECT * from " & tblname & " WHERE [ID]=" & """" & myvalue & "" & """"
rs.Open mysql, cn, adOpenStatic, adLockOptimistic, adCmdText

With rs
If rs.RecordCount = 0 Then
.AddNew
End If
.Fields(col1) = Cells(r, 1).Value
.Fields(col2) = Cells(r, 2).Value
.Fields(col3) = Cells(r, 2).Value
.Update
End With

Next r

Set cn = Nothing
Set rs = Nothing

End Sub

 

[meb135]

thanks for the quick replies.

Stapuff,
Your code seems exacltly what i need and i tried it out (the 2nd one). I'm not getting any errors but only the first row of data is being transfered to the table over and over again. In my test, i have 3 rows of data when i run the code, the 1st row gets added 3 times to the table. And when i run the code again, no data should be written to the table cause the ID is already in the table but the rows just get added to the table again.
Thoughts?

 

[meb135]

I re-worked your code a little and now all is working perfectly.
Thank you very much for your help. Much appreciated.

Here's the final code for anyone having the same request as i did.


Sub test()
Dim tblname As String
Dim r As Long
Dim col1, col2, col3, col4 As Range
Dim cn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim mysql, myvalue As String
Const DBPath = \\S11......Db1.mdb
Sheets("DData").Select
tblname = "T1_Detail"
rs.CursorLocation = adUseClient
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=" & DBPath
Mycount = Worksheets("DData").Range("A1").CurrentRegion.Rows.Count
r = 1
For r = 1 To Mycount
myvalue = Cells(r, 1).Value
Set rs = New ADODB.Recordset
mysql = "SELECT * from " & tblname & " WHERE [ID]=" & """" & myvalue & "" & """"
rs.Open mysql, cn, adOpenStatic, adLockOptimistic, adCmdText
With rs
If rs.RecordCount = 0 Then
.AddNew
End If
.Fields("ID") = Range("A" & r).Value
.Fields("Case_No") = Range("B" & r).Value
.Fields("File_No") = Range("C" & r).Value
.Update
End With
Next r
Set cn = Nothing
Set rs = Nothing
End Sub

 

[stapuff]

Glad it worked out for you