Update Access Database Table using Excel VBA

Question

I have a Time In and Time Out buttons in a form.

And I have a VBA Module code that saves the last entered data/last row of an entry from an Excel Table to Access Table and it works perfectly fine. This is called in a Time In command button of an Excel form. Here is a code snippet below.

 i = sht.Range("A" & Application.Rows.Count).End(xlUp).Row
    'x = 0
    Do While Len(Range("A" & i).Formula) > 0
' repeat until first empty cell in column A
        With rs
            .AddNew ' create a new record
            .Fields("cYear") = Range("A" & i).Value
            .Fields("MSID") = Range("B" & i).Value
            .Fields("cDate") = Range("C" & i).Value
            .Fields("Time In") = Range("D" & i).value
            .Fields("Time Out") = Range("E" & i).value

            .Range("E" & i) = .Fields("Time Out") 'added column F for ID as per comment below
            .Update
          'stores the new record
    End With
    i = i + 1
    Loop

Access Table has an ID which has an AutoNumber DataType and the rest of the fields have Text datatypes. Everytime a user clicks Time In button, current timestamp is automatically saved to Excel Table as well as to Access Table which is good. Now, during this click, I coded Column E value as blank in Excel as well as Access.

I already have a code for Updating the Time Out timestamp in Excel table.

Excel

I don't have a code for saving the Time Out timestamp in Access table. I am planning to make a new module for saving the Time Out timestamp to Access table. My problem is, how to code an update of Time Out timestamp for column E.

Access

I tried this in a new module for Time Out button below:

i = sht.Range("A" & Application.Rows.Count).End(xlUp).Row
        'x = 0
        Do While Len(Range("A" & i).Formula) > 0
    ' repeat until first empty cell in column A
            With rs
                .AddNew ' create a new record
                .Fields("Time Out") = Range("E" & i).value
                .Update
              'stores the new record
    End With
   i = i + 1
  Loop

But what it does is create a new row in Access Table.

tried updating through this snippet code:

i = sht.Range("A" & Application.Rows.count).End(xlUp).Row
'Create the SQL statement to retrieve the table data (the entire table)
    
 SQL = "SELECT * FROM " & accessTable & " WHERE ID = " & Range("F" & i) & _
    Range("B" & i).value = Environ$ & Range("E" & i).value = ""

'Create the ADODB recordset object.
Set rs = CreateObject("ADODB.Recordset")


    Do While Len(Range("A" & i).Formula) > 0
        With rs
            .Fields("Time Out") = Range("E" & i).value:
            .Update
    End With
    i = i + 1
    Loop

It does not update still.

Please advise. Thank you.

Answer 1

Run a select query first to retrieve the record to be updated.

Sub update()

    Const accessTable = "Table1"

    Dim sht As Worksheet, cn As Object, rs As Object
    Dim ID As Long, i  As Long, SQL As String
    
    Set cn = CreateObject("ADODB.Connection")
    With cn
        .Provider = "Microsoft.ace.OLEDB.12.0"
        .ConnectionString = "Data Source=" & ThisWorkbook.Path & "\Database1.accdb"
        .Open
    End With
    
    Set sht = ThisWorkbook.Sheets("Sheet1")
    With sht
        i = .Cells(.Rows.Count, "A").End(xlUp).Row
        ID = .Cells(i, "F")
    End With
    SQL = " SELECT * FROM " & accessTable & _
          " WHERE ID = " & ID
    
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open SQL, cn, adOpenDynamic, adLockOptimistic
    
    With rs
        .Fields("Time Out") = sht.Range("E" & i).Value
        .update
        .Close
    End With

    cn.Close
    MsgBox "Record ID=" & ID & " updated", vbInformation
    
End Sub