Code Improvement - SQL Statement Update SharePoint List

[TEIXEIRE]

Hello experts,

I have the code below which updates some columns of SharePoint list, based on excel values, through its ID in a loop, however if I have hundreds of entries it take some time intil updates, so I would like to know with you can help with improvements in the code. It uses SQL statements in VBA to update the SharePoint List. The Activex must be enabled.

Many thanks !

Option Explicit
Sub Update()

Dim tbl As ListObject
Dim x As Long

Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim mySQL As String

'TABLE Name
Set tbl = ActiveSheet.ListObjects("RSN_Technology_Change")

    'From first row of TABLE body/content until its last
    For x = 1 To tbl.ListRows.Count
    
        'additional/rule column to avoid loop
        If tbl.DataBodyRange(x, 10) = "" Then
        
            Set cnt = New ADODB.Connection
            Set rst = New ADODB.Recordset

            mySQL = "SELECT * FROM [RSN Technology Change] Where [ID] = " & tbl.DataBodyRange(x, 1) & ";"
            
            With cnt                                                                        
                .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;WSS;IMEX=0;RetrieveIds=Yes;DATABASE=https://companyServer.sharepoint.com/teams/AIBProduct;LIST={dc3d5a3c-762f-4211-9c66-1c6bde4c2f71};"
                .Open
            End With
            
            rst.Open mySQL, cnt, adOpenDynamic, adLockOptimistic
            
            If Not (rst.BOF And rst.EOF) Then
                rst!Status = tbl.DataBodyRange(x, 8)
                'Field Name with space put between []
                rst![Reason for Rejection] = tbl.DataBodyRange(x, 9)
                rst![Done Date] = Format(Now(), "dd/mm/yyyy HH:mm")
                rst.Update
            End If
            
            'additional/rule column to avoid loop
            tbl.DataBodyRange(x, 10) = "OK"
        
        Else
        End If
        
    Next x

'Close SQL Connection
If CBool(rst.State And adStateOpen) = True Then rst.Close
Set rst = Nothing
If CBool(cnt.State And adStateOpen) = True Then cnt.Close
Set cnt = Nothing

tbl.Refresh

MsgBox "your code has been executed", vbInformation, "Strategic Material Master Data"

End Sub

 

[TEIXEIRE]

John_w can you help ?
​

ID	RSN	SBU	L1	L1 Code	L2	L2 Code	Status	Reason For Rejection
1530	581743	AAC	Thermal Management (TM)	110	TM_Treated Powders	293	Approved
1532	582492	AAC	Thermal Management (TM)	110	TM_Treated Powders	293	Approved
1541	590188	AAC	Thermal Management (TM)	110	TM_Liquids Low Viscosity	287	Approved
1542	640384	AAC	Thermal Management (TM)	110	TM_Liquids Standard Viscosity	286	Approved
1545	640381	AAC	Thermal Management (TM)	110	TM_Liquids Standard Viscosity	286	Approved