Append and Update access at the same time through excel vba

Question

I have a table in access that I would like to update from excel vba. The new data comes from a saved excel file and each row has an unique ID as their primary key. I would like to make it so that when the new data comes in, any existing entry who's primary key matches that of a new entry will be replaced and any new data that is not replacing an old entry will create a new entry. I believe this is called a left or right join but I am not sure. Currently, my code only adds a new recordset and I can't seem to make it do a join because I am not too familiar with Access vba nor making excel and access talk to each other.

This is my code, which is run from excel:

Function AppendShipment(DatabaseLocation, ExcelFileLocation, dbTableName)
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet

Set wkb = Workbooks.Open(ExcelFileLocation)
Set wks = wkb.Worksheets("Sheet1")

Dim strConnection As String
Dim db As Object
Dim rs As Object
Dim r As Integer

Application.ScreenUpdating = False

strConnection = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & 
DatabaseLocation

Set db = CreateObject("ADODB.Connection")
    db.Open strConnection
    ' open a recordset
Set rs = CreateObject("ADODB.Recordset")
    rs.Open dbTableName, db, adOpenKeyset, adLockOptimistic


r = 2 ' the start row in the worksheet
    Do While Not Cells(r, 1) = ""
    ' repeat until first empty cell in column A
        With rs
            .AddNew ' create a new record
            ' add values to each field in the record
            .Fields("Customer") = Range("A" & r).Value
            .Fields("Customer Name") = wks.Range("B" & r).Value
            .Fields("Order Date") = wks.Range("C" & r).Value
            .Fields("Contract") = wks.Range("D" & r).Value
            .Fields("Sales Order") = wks.Range("E" & r).Value
            .Fields("Line#") = wks.Range("F" & r).Value
            .Fields("Customer Part") = wks.Range("G" & r).Value
            .Fields("AFS Part") = wks.Range("H" & r).Value
            .Fields("Decription 1") = wks.Range("I" & r).Value
            .Fields("Site") = wks.Range("J" & r).Value
            .Fields("Product Code") = wks.Range("K" & r).Value
            .Fields("Qty Ship") = wks.Range("L" & r).Value
            .Fields("Unit Price") = wks.Range("M" & r).Value
            .Fields("Customer PO Number") = wks.Range("N" & r).Value
            .Fields("Invoice Date") = wks.Range("O" & r).Value
            .Fields("Ship Date") = wks.Range("P" & r).Value
            .Fields("Ship To") = wks.Range("Q" & r).Value
            .Fields("Shipped-Dollars") = wks.Range("R" & r).Value
            .Fields("Month1") = wks.Range("S" & r).Value
            .Fields("Year1") = wks.Range("Y" & r).Value
            .Fields("Product Line") = wks.Range("U" & r).Value
            .Fields("Customer Group") = wks.Range("V" & r).Value
            .Fields("Customer&Product") = wks.Range("W" & r).Value
            .Fields("Customer Group 2") = wks.Range("X" & r).Value
            .Fields("Product Subgroup (Type 1)") = wks.Range("Y" & r).Value
            .Fields("Product Subgroup (Type 2)") = wks.Range("Z" & r).Value
            ' add more fields if necessary...
            .Update ' stores the new record
        End With
        r = r + 1 ' next row
    Loop
rs.Close
db.Close

ActiveWorkbook.Close SaveChanges:=False

Application.ScreenUpdating = True

End Function

Any helps is appreciated, thank you!

Currently, I have an autonumber field in the database named "UniqueDB_ID". Once I figure out the join, it will be replaced by a concatenation of Sales Order and Line#, which is always unique, but it will keep the same name of "UniqueDB_ID". Currently, If I use the concatenation, the code will give me an error because I am trying to append two records with the same primary key. — m4t3u5LP, Aug 03 '18 at 23:39
Possible duplicate of [Upserting in MS-access](https://stackoverflow.com/questions/6199417/upserting-in-ms-access) — June7, Aug 04 '18 at 07:34
Possible duplicate of [VBA code to update / create new record from Excel to Access](https://stackoverflow.com/questions/15709156/vba-code-to-update-create-new-record-from-excel-to-access) — Our Man in Bananas, Aug 04 '18 at 15:27

score 1 · Answer 1 · answered Aug 05 '18 at 11:29

1

To use a JOIN for an "UPSERT" in MS Access is only possible if the query has access to the source data. In your case, the source data is in Excel and you have to process each single row separately. I suggest to search the unique key in the database to decide whether to add a new record or edit the existing one:

' repeat until first empty cell in column A
With rs
    .FindFirst "[Sales Order]=" & wks.Range("E" & r).Value & _
        " AND [Line#] = " & wks.Range("F" & r).Value
    If .NoMatch Then .AddNew Else .Edit  ' create a new or edit existing record
    ' add values to each field in the record
    .Fields....

Since I can't see your data types, I assumed that both [Sales Order] and [Line#] are numbers. If not, you will have to wrap single quotes around the cell values calling the .FindFirst method.

answered Aug 05 '18 at 11:29

Wolfgang Kais

4,010
2
10
17

They are actually short text. I am not sure how to wrap the single quotes like you mentioned and I keep getting a runtime error. Can you show me? – m4t3u5LP Aug 06 '18 at 16:08
This is what I am trying: With rs Debug.Print "[UniqueDB_ID]=" & "'" & wks.Range("A" & r).Value & wks.Range("B" & r).Value & "'" .FindFirst "[UniqueDB_ID]=" & "'" & wks.Range("A" & r).Value & wks.Range("B" & r).Value & "'" If .NoMatch Then .AddNew Else .Edit ' create a new record or edit existing record It prints out this value as a string: [UniqueDB_ID]='E3100641' which is the correct unique key, but I get Run-time error '438': Object doesn't support his property or method. – m4t3u5LP Aug 06 '18 at 16:21
Ok, I might have forgottenthat ADO doesn't have an edit method… so just leave out the `Else` part. – Wolfgang Kais Aug 06 '18 at 19:54

score 0 · Accepted Answer · answered Aug 06 '18 at 17:30

I figured it out!

First, i used .Filter to see if anything matches the current records. If .RecordCount = 0, then nothing matches, so then it does .AddNew. If something does match, it turns out .Edit doesn't work for ADO, instead .MoveFirst needs to be used. Since only 1 recordset will ever match because I am filtering by the primary key and there can be no duplicates, this will edit that recordset no problem.

Function AppendShipment(DatabaseLocation, ExcelFileLocation, dbTableName)
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet

Set wkb = Workbooks.Open(ExcelFileLocation)
Set wks = wkb.Worksheets("Sheet1")

Dim strConnection As String
Dim db As Object
Dim rs As Object
Dim r As Integer

Application.ScreenUpdating = False

strConnection = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & DatabaseLocation

Set db = CreateObject("ADODB.Connection")
    db.Open strConnection
    ' open a recordset
Set rs = CreateObject("ADODB.Recordset")
    rs.Open dbTableName, db, adOpenKeyset, adLockOptimistic


r = 2 ' the start row in the worksheet
    Do While Not Cells(r, 1) = ""
    ' repeat until first empty cell in column A
        With rs
            Debug.Print "[UniqueDB_ID]=" & "'" & Trim(wks.Range("E" & r).Value) & 
wks.Range("F" & r).Value & "'"
        .Filter = "[UniqueDB_ID]=" & "'" & Trim(wks.Range("E" & r).Value) & 
wks.Range("F" & r).Value & "'"
        If .RecordCount = 0 Then .AddNew Else .MoveFirst  ' create a new record or 
edit existing record
        ' add values to each field in the record
        .Fields("UniqueDB_ID") = Trim(wks.Range("E" & r).Value) & wks.Range("F" & 
r).Value
        .Fields("Customer") = wks.Range("A" & r).Value
        .Fields("Customer Name") = wks.Range("B" & r).Value
        .Fields("Order Date") = wks.Range("C" & r).Value
        .Fields("Contract") = wks.Range("D" & r).Value
        .Fields("Sales Order") = Trim(wks.Range("E" & r).Value)
        .Fields("Line#") = wks.Range("F" & r).Value
        .Fields("Customer Part") = wks.Range("G" & r).Value
        .Fields("AFS Part") = wks.Range("H" & r).Value
        .Fields("Decription 1") = wks.Range("I" & r).Value
        .Fields("Site") = wks.Range("J" & r).Value
        .Fields("Product Code") = wks.Range("K" & r).Value
        .Fields("Qty Ship") = wks.Range("L" & r).Value
        .Fields("Unit Price") = wks.Range("M" & r).Value
        .Fields("Customer PO Number") = wks.Range("N" & r).Value
        .Fields("Invoice Date") = wks.Range("O" & r).Value
        .Fields("Ship Date") = wks.Range("P" & r).Value
        .Fields("Ship To") = wks.Range("Q" & r).Value
        .Fields("Shipped-Dollars") = wks.Range("R" & r).Value
        .Fields("Month1") = wks.Range("S" & r).Value
        .Fields("Year1") = wks.Range("Y" & r).Value
        .Fields("Product Line") = wks.Range("U" & r).Value
        .Fields("Customer Group") = wks.Range("V" & r).Value
        .Fields("Customer&Product") = wks.Range("W" & r).Value
        .Fields("Customer Group 2") = wks.Range("X" & r).Value
        .Fields("Product Subgroup (Type 1)") = wks.Range("Y" & r).Value
        .Fields("Product Subgroup (Type 2)") = wks.Range("Z" & r).Value
        ' add more fields if necessary...
        .Update ' stores the new record
    End With
    r = r + 1 ' next row
    Loop
rs.Close
db.Close

ActiveWorkbook.Close SaveChanges:=False

Application.ScreenUpdating = True

End Function

Thank you for your help!

Append and Update access at the same time through excel vba

2 Answers2