Skip to main content
1 of 2

One way Synchronize 2 Access Tables with VBA ADODB

I am synchronizing two MS-Access databases. One of them on a network drive, the other one on the local machine. (For testing purposes both in the same directory)

The Databases both contain a table named "tblCheckup" with an essential ID Field called "checkGUID"

I am aware that this will probably fail if there are no records in either of the Tables but this is of no concern.

Since i am fairly new to ADODB and MS Access i am looking for any performance issues with larger scales. Expected table size growth is around 3000 entries per year.

I am thankful for any hints concerning possible runtime errors, possible bottlenecks in speed and performance issues in larger scales as stated above. Also i am not really sure if i used the best CursorType and LockType.

Private Sub SyncToServerTest()
Dim rsExists As Boolean
Dim lngCount As Long

Dim connLokal As ADODB.Connection
Dim connServer As ADODB.Connection
Dim dataLokal As ADODB.Recordset
Dim dataServer As ADODB.Recordset

Set connLokal = New ADODB.Connection
Set connServer = New ADODB.Connection
Set dataLokal = New ADODB.Recordset
Set dataServer = New ADODB.Recordset

connLokal.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\AccessSyncTest\Lokal.accdb;Persist Security Info=False;"
connLokal.Open
connServer.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\AccessSyncTest\Server.accdb;Persist Security Info=False;"
connServer.Open

With dataLokal
    .ActiveConnection = connLokal
    .Source = "tblCheckup"
    .LockType = adLockPessimistic
    .CursorType = adOpenForwardOnly
    .Open
    
    If .EOF Then
        Debug.Print "No entries in Local Table"
        Exit Sub
    Else
        .MoveFirst
    End If
    
End With

With dataServer
    .ActiveConnection = connServer
    .Source = "tblCheckup"
    .LockType = adLockPessimistic
    .CursorType = adOpenForwardOnly
    .Open
    
    If .EOF Then
        Debug.Print "No entries in Server Table"
        Exit Sub
    Else
        .MoveFirst
    End If
End With

Do Until dataLokal.EOF
    rsExists = False
    Do Until dataServer.EOF Or rsExists
        If dataLokal.Fields("checkGUID").Value = dataServer.Fields("checkGUID").Value Then
            rsExists = True
        End If
        dataServer.MoveNext
    Loop
    If Not rsExists Then
        dataServer.AddNew
         For lngCount = 0 To dataLokal.Fields.Count - 1
            dataServer.Fields(dataLokal.Fields(lngCount).Name).Value = dataLokal.Fields(lngCount).Value
        Next lngCount
        Debug.Print dataLokal.Fields("checkGUID").Value & " was added"
        
    End If
    dataServer.MoveFirst
    dataLokal.MoveNext
Loop


Set dataLokal = Nothing
Set dataServer = Nothing
Set connLokal = Nothing
Set connServer = Nothing 
End Sub