How to speed up database update code

[vishal120]

I have the following code which am using to add new or update records to Access database. For 243 records actually this is taking 17 secs to update which is very long, as the records are going to increase more and more daily.

Here is the code am actually :

Sub Add_Update_Data_To_Base()
applications-print.html
Application.ScreenUpdating = False    ' Prevents screen refreshing.

Dim cnn As ADODB.Connection
Dim RST As ADODB.Recordset
Dim fld As ADODB.Field
Dim MyConn
Dim lngRow As Long
Dim lngId, LR, Upd
Dim j As Long
Dim ssql As String

LR = Range("A" & Rows.Count).End(xlUp).Row
Upd = LR - 1

'set counter time
Start_Time = Time

lngRow = 11
Do While lngRow <= LR

Sheets("marketing").Activate
lngId = Cells(lngRow, 1).Value


ssql = "SELECT * FROM Tbl_Sample_details WHERE Sample_Auto_ref = '" & lngId & "'"


Set cnn = New ADODB.Connection


'Office Connection:

'MyConn = "Provider = Microsoft.ACE.OLEDB.12.0;" & _
"Data Source = C:\Karina_Int\Database\Sample_Process.accdb"

'Home Connection:
MyConn = "Provider = Microsoft.ACE.OLEDB.12.0;" & _
"Data Source = E:\Karina_Int\Sample_Planning\Database\Sample_Process.accdb"


With cnn
' .Provider = "Microsoft.Jet.OLEDB.4.0"
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Open MyConn

End With

Set RST = New ADODB.Recordset
RST.CursorLocation = adUseServer
RST.Open ssql, ActiveConnection:=cnn, _
CursorType:=adOpenKeyset, LockType:=adLockOptimistic

'  If rs.BOF And rs.EOF Then
'    MsgBox "recordset is empty"
'Else
'    rs.MoveLast
'    MsgBox "recordset contains " & rs.RecordCount & " rows"
'End If
            
'   Set rs = Me.Recordset.Clone
'If Me.Recordset.RecordCount = 0 Then 'checks for number of records
'   MsgBox "There is no records"
'End If


            
            With RST
            'If Not (.BOF And .EOF) = True Then
            If .RecordCount = 0 Then
                      .AddNew
                        .Fields("Sample_Auto_ref") = Cells(lngRow, 1).Value
                        .Fields("Marketing_Manager") = Cells(lngRow, 2).Value
                        .Fields("Merchandiser") = Cells(lngRow, 3).Value
                        .Fields("Saison") = Cells(lngRow, 4).Value
                        .Fields("Client") = Cells(lngRow, 5).Value
                        .Fields("Ref_Client") = Cells(lngRow, 6).Value
                        .Fields("Ref_Karina") = Cells(lngRow, 7).Value
                        .Fields("Depart") = Cells(lngRow, 8).Value
                        .Fields("Theme") = Cells(lngRow, 9).Value
                        .Fields("Desc") = Cells(lngRow, 10).Value
                        .Fields("Type_Echantillion") = Cells(lngRow, 11).Value
                        .Fields("Taille") = Cells(lngRow, 12).Value
                        .Fields("Qty") = Cells(lngRow, 13).Value
                        .Fields("Keep_KI") = Cells(lngRow, 14).Value
                        .Fields("Type_Lavage") = Cells(lngRow, 15).Value
                        .Fields("Colori_Gmt_dyed") = Cells(lngRow, 16).Value
                        .Fields("Valeur_Ajouter") = Cells(lngRow, 17).Value
                        .Fields("Date_request_Merc") = Cells(lngRow, 18).Value
                        .Fields("Date_Liv_Reviser") = Cells(lngRow, 19).Value
                        .Fields("Date_Livraison_Ech") = Cells(lngRow, 20).Value
                        .Fields("Comm_Merc") = Cells(lngRow, 21).Value
                        .Fields("Comm_Client") = Cells(lngRow, 22).Value
                        .Fields("PendIng_Rel") = Cells(lngRow, 23).Value
                        .Fields("Date_Envoyer_Client") = Cells(lngRow, 24).Value
                        .Fields("Courier_No") = Cells(lngRow, 25).Value
                       .Update
                    'MsgBox "record added new"
                Else
                     
                        .Fields("Sample_Auto_ref") = Cells(lngRow, 1).Value
                        .Fields("Marketing_Manager") = Cells(lngRow, 2).Value
                        .Fields("Merchandiser") = Cells(lngRow, 3).Value
                        .Fields("Saison") = Cells(lngRow, 4).Value
                        .Fields("Client") = Cells(lngRow, 5).Value
                        .Fields("Ref_Client") = Cells(lngRow, 6).Value
                        .Fields("Ref_Karina") = Cells(lngRow, 7).Value
                        .Fields("Depart") = Cells(lngRow, 8).Value
                        .Fields("Theme") = Cells(lngRow, 9).Value
                        .Fields("Desc") = Cells(lngRow, 10).Value
                        .Fields("Type_Echantillion") = Cells(lngRow, 11).Value
                        .Fields("Taille") = Cells(lngRow, 12).Value
                        .Fields("Qty") = Cells(lngRow, 13).Value
                        .Fields("Keep_KI") = Cells(lngRow, 14).Value
                        .Fields("Type_Lavage") = Cells(lngRow, 15).Value
                        .Fields("Colori_Gmt_dyed") = Cells(lngRow, 16).Value
                        .Fields("Valeur_Ajouter") = Cells(lngRow, 17).Value
                        .Fields("Date_request_Merc") = Cells(lngRow, 18).Value
                        .Fields("Date_Liv_Reviser") = Cells(lngRow, 19).Value
                        .Fields("Date_Livraison_Ech") = Cells(lngRow, 20).Value
                        .Fields("Comm_Merc") = Cells(lngRow, 21).Value
                        .Fields("Comm_Client") = Cells(lngRow, 22).Value
                        .Fields("PendIng_Rel") = Cells(lngRow, 23).Value
                        .Fields("Date_Envoyer_Client") = Cells(lngRow, 24).Value
                        .Fields("Courier_No") = Cells(lngRow, 25).Value
                    RST.Update
            
            
            
                'MsgBox "update me"
                End If
            End With
'rst.Close 'the connection
RST.Close
cnn.Close
Set RST = Nothing
Set cnn = Nothing

lngRow = lngRow + 1

Loop
'>>>making a calculation on the end time and start time
    End_Time = Time
    Time_String = Format(End_Time - Start_Time, "ss")
    
    '& Time_String & " secs"
MsgBox "Data updated " & Upd & " records in " & Time_String & " secs"
End Sub

Thanks for helping and guiding on this please as I really need a way to speed up the update.

Thanking in advance.