Add the 1 last row of data from Excel Sheet Table to Access Database Table

Question

I have here a simple form that uses a code from VBA Excel connecting to an exported to SharePoint List MS Access Database. Since I am just learning Excel to Access, I just copied the code below from the internet and pasted it in an Excel VBA module. The module is being called by the Command button of the form. The purpose of the module is to add data from Excel Sheet table to Access Database table. The code works to its purpose.

My problem is that, the code saves data from row 1 down to the last row every time I hit the button. It lags when I hit the button. If you can see the image below, it is showing that the rows were saved successfully but it piled up in Database which reflected in SharePoint. It already has reached 110 entries when in sheet it only has 19 entries.

The Form

The SharePoint List based from the exported MS Access Database Table

My expected outcome every time I hit the button is that, it should only save the last entry or the last row of data I made and not the whole Sheet table.

Here is the Command button code:

Option Explicit
Private Sub CommandButton1_Click()
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("Trial TRC")
    Dim n As Long
    n = sh.Range("A" & Application.Rows.Count).End(xlUp).Row
    sh.Range("A" & n + 1).Value = TextBox1.Value
    sh.Range("B" & n + 1).Value = TextBox2.Value
    sh.Range("C" & n + 1).Value = TextBox3.Value
    
    Call AddRecordsIntoAccessTable
End Sub

Here is the Module:

Option Explicit

Sub AddRecordsIntoAccessTable()
 'Declaring the necessary variables.
    Dim accessFile  As String
    Dim accessTable As String
    Dim sht         As Worksheet
    Dim lastRow     As Long
    Dim lastColumn  As Integer
    Dim con         As Object
    Dim rs          As Object
    Dim sql         As String
    Dim i           As Long
    Dim j           As Integer
            
    'Disable the screen flickering.
    Application.ScreenUpdating = False
    
    'Specify the file path of the accdb file. You can also use the full path of the file like this:
    'AccessFile = "C:\Users\Christos\Desktop\Sample.accdb"
    accessFile = ThisWorkbook.Path & "\" & "trialpower1.accdb"
         
    'Ensure that the Access file exists.
    If FileExists(accessFile) = False Then
        MsgBox "The Access file doesn't exist!", vbCritical, "Invalid Access file path"
        Exit Sub
    End If
    
    'Set the name of the table you want to add the data.
    accessTable = "Trial_TRC"
                
    'Set the worksheet that contains the data.
    On Error Resume Next
    Set sht = ThisWorkbook.Sheets("Trial TRC")
    If Err.Number <> 0 Then
        MsgBox "The given worksheet does not exist!", vbExclamation, "Invalid Sheet Name"
        Exit Sub
    End If
    Err.Clear
        
    'Find the last row and last column in the given worksheet.
    With sht
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With
    
    'Check if there are data in the worksheet.
    If lastRow < 2 Or lastColumn < 1 Then
        MsgBox "There are no data in the given worksheet!", vbCritical, "Empty Data"
        Exit Sub
    End If
        
    'Create the ADODB connection object.
    Set con = CreateObject("ADODB.connection")
    
    'Check if the object was created.
    If Err.Number <> 0 Then
        MsgBox "The connection was not created!", vbCritical, "Connection Error"
        Exit Sub
    End If
    Err.Clear
    
    'Open the connection.
    con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & accessFile
    
    'Create the SQL statement to retrieve the table data (the entire table).
    sql = "SELECT * FROM " & accessTable
    
    'Create the ADODB recordset object.
    Set rs = CreateObject("ADODB.Recordset")
    
    'Check if the object was created.
    If Err.Number <> 0 Then
        Set rs = Nothing
        Set con = Nothing
        MsgBox "The recordset was not created!", vbCritical, "Recordset Error"
        Exit Sub
    End If
    Err.Clear
             
    'Set the necessary recordset properties.
    rs.CursorType = 1   'adOpenKeyset on early binding
    rs.LockType = 3     'adLockOptimistic on early binding
        
    'Open the recordset.
    rs.Open sql, con
    
    'Add the records from Excel to Access by looping through the rows and columns of the given worksheet.
    'Here the headers are in the row 1 and they are identical to the Access table headers.
    'This is the reason why, for example, there are no spaces in the headers of the sample worksheet.
    For i = 2 To lastRow
        rs.AddNew
        For j = 1 To lastColumn
            'This is how it will look like the first time (i = 2, j = 1):
            'rs("FirstName") = "Bob"
            rs(sht.Cells(1, j).Value) = sht.Cells(i, j).Value
        Next j
        rs.Update
    Next i
        
    'Close the recordet and the connection.
    rs.Close
    con.Close
    
    'Release the objects.
    Set rs = Nothing
    Set con = Nothing
    
    'Re-enable the screen.
    Application.ScreenUpdating = True

    'Inform the user that the macro was executed successfully.
    MsgBox lastRow - 1 & " rows were successfully added into the '" & accessTable & "' table!", vbInformation, "Done"
    
End Sub

Function FileExists(FilePath As String) As Boolean
 
    '--------------------------------------------------
    'Checks if a file exists (using the Dir function).
    '--------------------------------------------------
 
    On Error Resume Next
    If Len(FilePath) > 0 Then
        If Not Dir(FilePath, vbDirectory) = vbNullString Then FileExists = True
    End If
    On Error GoTo 0
 
End Function

Please advise. Thank you.

Answer 1

I changed the code from where you can see:

For i = 2 to lastRow
down to 
Next i

to this code:

 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("Year") = Range("A" & i).Value
            .Fields("MSID") = Range("B" & i).Value
            .Fields("Date") = Range("C" & i).Value
            .Update
          'stores the new record
    End With
    i = i + 1
    Loop

And it successfully added 1 row of data only from Excel Table to Access Table.