CODEWITHSUNDEEP
excelms-accessvba
m4t3u5LP
m4t3u5LP

Reputation: 1

Append and Update access at the same time through excel vba

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!

Upvotes: 0

Views: 1674

Answers (2)

m4t3u5LP
m4t3u5LP

Reputation: 1

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!

Upvotes: 0

Wolfgang Kais
Wolfgang Kais

Reputation: 4100

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.

Upvotes: 1

Related Questions