Extremely Slow VBA Code - Update Access via Excel

[excelnewcomer123]

I found a code that I have edited to update access records via Excel (Code below). I have tested it and it works perfectly, however it takes 3 minutes to update 6 records (rows). Is there any way to fix this and make it much faster?

The code searches for the primary key in an excel row, and updates fields 9-12 for that uniqueID to access. Realistically, I only need rows that were edited after the latest save to be updated, but my VBA knowledge is limited and I do not know how to do this, let alone if it is possible.

Sub UpdateAccess() 
 On Error Resume Next
 
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

Const TARGET_DB = "Access Database.accdb"

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

lngRow = 1
Do While lngRow <= LR

lngID = Cells(lngRow, 13).Value

sSQL = "SELECT * FROM QuoteDatabase WHERE UniqueID = " & [lngID]

Set cnn = New ADODB.Connection
MyConn = ThisWorkbook.Path & Application.PathSeparator & TARGET_DB
With cnn
.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

'Load all records from Excel to Access.
With rst

.Fields("Field9") = Cells(lngRow, 9).Value
.Fields("Field10") = Cells(lngRow, 10).Value
.Fields("Field11") = Cells(lngRow, 11).Value
.Fields("Field12") = Cells(lngRow, 12).Value

rst.Update
End With

' Close the connection
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing

lngRow = lngRow + 1

Loop

MsgBox "You just updated " & Upd & " records"
End Sub

thank you

 

[CalcSux78]

How many records (on average) are you updating? It looks like each loop updates 4 fields for each record.

If you have a large set of records that you are updating, that could explain part of the slowness. If it's only 1 record updating 4 fields for the entire sub, I'm not sure if modifying your code will give you the performance jump you're looking for. I would question the location of the Access database file. It sounds like it may be located on a remote server that isn't in your physical location (which will slow down the process).

 

[excelnewcomer123]

It's a log, so the number of records will grow exponentially once this utilized. Right now excel has only 6 records and it is very slow. Both the database and the excel are on a remote, shared drive.
I'm wondering if there is a different way then to perform the similar task? Is there a way to only update records that were changed after the last update? (so instead of updating every record, every time - it would only update a handful?
Or possibly it is faster to copy all rows with a value in fields 9-12 and paste them over the existing access database? (since the excel is an exported table from access anyways)

I seem to be reading that there is no easy way to link back and forth due to a lawsuit MS encountered a few years back. Access licenses are limited, so I am trying to make everything doable via excel



Thank you for your time

 

[excelnewcomer123]

Is this something that can be a batchupdate or recordset Update instead? I dont understand either very well, but have come across them in research. If so, how would I go about changing that?

 

[CalcSux78]

I would use the Worksheet_Change event to trigger your code to run. Then, you'd be able to target exactly which single record needs to change.

I can give a more detailed example if you can give some info:

• Table Name of your MS Access table.
• Field Names - (The header row of your table in MS Access)
• Add or Update? (Will you only update records or would you ever use this to create a new record?)
• Does your spreadsheet contain any external data from the database?

 

[excelnewcomer123]

So it would update the record as it is changed?

-Table name of MS access = QuoteDatabase
-Field Names = Field1, Field2, Field3, Field4, Field5, Field6, Field7, Field8, Field9, Field10, Field11, Field12, UniqueID
-Will only be updating fields 9-12
-The entire 13 rows are automatically refreshing, upon open, in excel FROM the access table, "quotedatabase" (i have created an external link)

Hope that helps - thank you again!

 

[CalcSux78]

This is un-tested, but should get you going in the right direction.

'Place this code on the Sheet object level containing data to send
Const MyConn As String = "Data Source=" & ThisWorkbook.Path & _
                    Application.PathSeparator & "Access Database.accdb;"

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rs As New ADODB.Recordset
Dim cn As New ADODB.Connection
Dim ssql As String, tbl As String
Dim lngID As Long
Dim lngRow As Long

On Error GoTo WrapUp        'disable this line if you need to error test code

Const MyConn As String = "Data Source=" & ThisWorkbook.Path & _
                    Application.PathSeparator & "Access Database.accdb;"
                    
tbl = "QuoteDatabase"
lngRow = Target.Row
lngID = Cells(lngRow, 13).Value

cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & MyConn
ssql = "SELECT * FROM " & tbl & " WHERE " & tbl & ".UniqueID=" & lngID

With rs
    .Open Source:=ssql, ActiveConnection:=cn, CursorType:=adOpenKeyset, _
        LockType:=adLockOptimistic, Options:=adCmdTableDirect
    .Fields("Field9") = Cells(lngRow, 9).Value
    .Fields("Field10") = Cells(lngRow, 10).Value
    .Fields("Field11") = Cells(lngRow, 11).Value
    .Fields("Field12") = Cells(lngRow, 12).Value
    'repeat for all required fields
    .Update
    .Close
End With

WrapUp:         'return here on error to close connections

Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub

 

[excelnewcomer123]

This is great, thank you very much. The only change I had to make is that the Const statement cannot be dynamic content, so i had to change that - solution being in this thread

Compile Error: Constant Expression Required. Passing String to Constant

 

[CalcSux78]

Glad it worked... on the error, I guess Cunningham's Law held up on it!

 

[afrpompeia]

I dont know if this is a correct place. If not, tell me how to post similar problem but on local machine with access and excel 2010
I made a excel procedure to test for extremely slow vba to access into a command button;
Here is my code:
Public Sub abretabela(ByVal rs As ADODB.Recordset, ByVal squery As String)
On Error GoTo AbreError
With rs
.Source = squery
Set .ActiveConnection = conn
.CursorType = adOpenDynamic
.LockType = adLockPessimistic
.CursorLocation = adUseClient
.Open
End With
AbreError:
If Err.Number <> 0 Then
MsgBox "Erro - " & Err.Description
' Resume
End If
End Sub

Public Sub CloseConnection()
conn.Close
Set conn = Nothing
End Sub

Public Sub OpenConnection()
Dim strDbPath As String
strDbPath = ThisWorkbook.Path
'conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & strDbPath & "\CriaQuestoes1.accdb"
conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strDbPath & "\CriaQuestoes2.21.accdb"
conn.Open
End Sub

Private Sub CommandButton1_Click()
Dim squery As String
Dim i As Integer
Dim s1(1 To 5) As String
Dim s2(1 To 5) As String
Dim s3(1 To 5) As String
Dim i1(1 To 5) As Integer
Dim i2(1 To 5) As Integer
Dim L1(1 To 5) As Long
On Error GoTo errao
LerRegistroBD
s1(1) = 534: s1(2) = 654: s1(3) = 765: s1(4) = 876: s1(5) = "888"
s2(1) = "Alvaro": s2(2) = "Angela": s2(3) = "Carina": s2(4) = "Marina": s2(5) = "martha"
s3(1) = "Silva": s3(2) = "Gomes": s3(3) = "Ramos": s3(4) = "Souza": s3(5) = "Santos"
i1(1) = 6: i1(2) = 12: i1(3) = 14: i1(4) = 18: i1(5) = 24
i2(1) = 551: i2(2) = 1854: i2(3) = 2554: i2(4) = 3368: i2(5) = 5899
L1(1) = 54287426: L1(2) = 94875412: L1(3) = 14587414: L1(4) = 20540489: L1(5) = 54874526:
For i = 1 To 5
´-----------------------------------------
OpenConnection
´-------------------------------------------
conn.BeginTrans
squery = "UPDATE Employee SET empid ='" & s1(i) & "'"
squery = squery & ",fname ='" & s2(i) & "',lname ='" & s3(i)
squery = squery & "',idade=" & i1(i) & ",anon=" & i2(i)
squery = squery & ",fones=" & L1(i) & " WHERE Código=1;"
Debug.Print squery
abretabela rs, squery
conn.CommitTrans
If (rs.State And adStateOpen) = adStateOpen Then
rs.Close
Set rs = Nothing
End If
CloseConnection
Next
erraoexit:
Exit Sub
errao:
MsgBox Err.Number & " " & Err.Description
Resume 'erraoexit
End Sub

Private Sub LerRegistroBD()
Dim squery As String
On Error GoTo errado
squery = "Select empid,fname,lname,idade,anon,fones from Employee WHERE código=1;"
OpenConnection
conn.BeginTrans
abretabela rs, squery
Debug.Print rs.Fields("empid") & "-" & rs.Fields("fname") & "-" & rs.Fields("lname") & "-" & rs.Fields("idade") & "-" & rs.Fields("anon") & "-" & rs.Fields("fones") & " WHERE código=1"
conn.CommitTrans
rs.Close
Set rs = Nothing
CloseConnection
erradoexit:
Exit Sub
errado:
MsgBox Err.Number & " " & Err.Description
Resume erradoexit
End Sub

The table employee:
Código automatic, empId text(10),fname text(40),lname text(40),idade integer,anon integer,fones long.
Executing with F5 stopping between dashed line and looking the table on access, the employee table was updated 10 to 20 seconds after closing connections. Is there a way to update the record immediately?
(sorry, english is not my native language)