Multi-User Access DB Table

tjdrake

tjdrake

New Member
Joined
Aug 2, 2022
Messages
19
Office Version
  1. 2021
Platform
  1. Windows
Hello Team,
I've been struggling with this all week, and am running up against a deadline to make this work for my team. Here are the essentials:
  • The MS 2021 Access DB sits on a SharePoint Server;
  • The SharePoint permissions have been granted to Everyone;
  • The code updates with a new record perfectly every time from my desktop;
  • When other users attempt to update the DB, the response is an error code 3709, "The connection cannot be used to perform this operation. It is either closed or invalid in this context."
  • I've adLockOptimistic and adLockPessimistic without any yield;
  • I believe that it has to do with MS Access creating the record lock file, laccdb, but I am no MS Access SME, so hear I am...
  • Client Settings: Default Open Mode:=Shared; Default Record Locking:=No Locks.
Thank you, in advance, for your time and assistance.

DB Client Settings.png


Sub updateAccess(blnEndofShift As Boolean)

If Not blnEndofShift Then Exit Sub

'Presentation Management
Call ToggleHideUnhideDataSheets("Show")

'Resume Next on an Error
Dim strErrMsg As String
On Error GoTo ErrorMessage
Let strErrMsg = ""

'Connection Declarations
Let strErrMsg = "Connection"
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=\\...\Database\RTS_SPT_Data.accdb;Persist Security Info=False;"
cn.Open

On Error Resume Next
Dim tmTimeKeeper As Date
If Err.Number = -2147467259 Then tmTimeKeeper = Now + TimeValue("00:01:00")

Do While cn.State <> adStateOpen And Now <= tmTimeKeeper
cn.Open
DoEvents
Application.Wait (Now + TimeValue("0:00:5"))
If cn.State = adStateOpen Then
Err.Clear
Exit Do
End If
Loop

If Not cn.State = adStateOpen Then
MsgBox "Please try again. The DB server is locked at this time", vbOKCancel, , "DB Write Error"
GoTo ExitSub
End If

'Turn-off Resume Next
On Error GoTo ErrorMessage

'Recordset Declaration
Dim rstADO As ADODB.Recordset
Set rstADO = New ADODB.Recordset

Let strErrMsg = "Opening DB"
rstADO.Open "RTS_SPT_Adoption_Data", cn, adOpenDynamic, adLockOptimistic, adCmdTable
' Types of Locks - ActiveX Data Objects (ADO)
'adLockBatchOptimistic
'adLockOptimistic
'adLockPessimistic
'adLockReadOnly
'adLockUnspecified


'Add a new record
Let strErrMsg = "Adding a new record."
rstADO.AddNew

'Declarations
Dim wbWorkbook As Workbook
Dim wsWorksheet As Worksheet
Dim rngName As Range
Dim intFind1 As Integer
Dim intFind2 As Integer
Dim strFound As String
Dim sProduct As String
Dim cPrice As String
Dim intCntr As Integer



Dim dynArrayStr() As String
Dim intArrayMax As Integer

Const cnstFindStr1 As String = "RTS"
Const cnstFindStr2 As String = "Total"

Set wbWorkbook = ThisWorkbook
Set wsWorksheet = wbWorkbook.Sheets("parms")

' Load Station, DateTime Stamp, DS Reset Owner
Let strErrMsg = "Updating fields in a record."

Set wsWorksheet = wbWorkbook.Sheets("parms")
rstADO!DeliveryStation = wsWorksheet.Range("DlvryStn")
rstADO!DateTime = Now
rstADO!Shift = "RTS"
rstADO!StowBagReplenOwner = wsWorksheet.Range("StowBagReplenOwner")
rstADO!DCAPInductOVPkgPct = wsWorksheet.Range("DCAP_Induct_OV_package")
rstADO!AvgShipPerBag = wsWorksheet.Range("Avg_Shipments_per_Bag")

' Other Plan Parameters
rstADO!StowBagReplenOwner = wsWorksheet.Range("StowBagReplenOwner")

' Load Core and PFSD Volume
Set wsWorksheet = wbWorkbook.Sheets("PvA")

rstADO!CoreVolumePlan = wsWorksheet.Range("E5")
rstADO!CoreVolumeActual = wsWorksheet.Range("F5")
rstADO!DispatchVolumePlan = wsWorksheet.Range("J5")
rstADO!DispatchVolumeActual = wsWorksheet.Range("K5")
rstADO!AdhocVolumePlan = wsWorksheet.Range("O5")
rstADO!AdhocVolumeActual = wsWorksheet.Range("P5")
rstADO!SWAVolumePlan = 0
rstADO!SWAVolumeActual = 0
rstADO!SameDayVolumePlan = wsWorksheet.Range("T5")
rstADO!SameDayVolumeActual = wsWorksheet.Range("U5")
rstADO!RTSVolumePlan = wsWorksheet.Range("Y5")
rstADO!RTSVolumeActual = wsWorksheet.Range("Z5")
rstADO!TotalVolumePlan = wsWorksheet.Range("AD5")
rstADO!TotalVolumeActual = wsWorksheet.Range("AE5")
rstADO!HistBagsLeftover = IIf(IsNumeric(wsWorksheet.Range("HistLeftoverBags")), wsWorksheet.Range("HistLeftoverBags"), 0)
rstADO!HistAdhocVolume = IIf(IsNumeric(wsWorksheet.Range("HistAdhocVolume")), wsWorksheet.Range("HistAdhocVolume"), 0)

'Find the columns that have the values sought
wsWorksheet.Rows(3).Select
Let strFound = Selection.Find(cnstFindStr1, lookat:=xlWhole, MatchCase:=False).AddressLocal
Let intFind1 = Range(strFound).Column
Let strFound = Selection.Find(cnstFindStr2, lookat:=xlWhole, MatchCase:=False).AddressLocal
Let intFind2 = Range(strFound).Column

'Begin preparation for processing the day's plan and actuals (PvA Tab)
Let intArrayMax = wsWorksheet.Range("PvA_ProcessPaths").Count
ReDim dynArrayStr(intArrayMax)
For intCntr = 1 To intArrayMax
wsWorksheet.Range("PvA_ProcessPaths").Activate
If Selection(intCntr) <> "" Then
Let dynArrayStr(intCntr) = Selection(intCntr)
End If
Next

' Load Plan Rates and Hours (Plan and Actual)
Let intCntr = 0
For intCntr = 1 To intArrayMax
DoEvents
Select Case Selection(intCntr)
Case "Auto Scan Induct Loader"
rstADO!AutoScanInductLoader_PlanRate = IIf(IsNumeric(Selection(intCntr).Offset(0, intFind2 - 1)), Selection(intCntr).Offset(0, intFind2 - 1), 0)
rstADO!RTSAutoScanInductLoader_PlanHours = IIf(IsNumeric(Selection(intCntr).Offset(0, intFind1 - 2)), Selection(intCntr).Offset(0, intFind1 - 2), 0)
rstADO!RTSAutoScanInductLoader_ActualHours = IIf(IsNumeric(Selection(intCntr).Offset(0, intFind1 - 1)), Selection(intCntr).Offset(0, intFind1 - 1), 0)
rstADO!TotalAutoScanInductLoader_PlanHours = IIf(IsNumeric(Selection(intCntr).Offset(0, intFind2 - 2)), Selection(intCntr).Offset(0, intFind2 - 2), 0)
rstADO!TotalAutoScanInductLoader_ActualHours = IIf(IsNumeric(Selection(intCntr).Offset(0, intFind2 - 1)), Selection(intCntr).Offset(0, intFind2 - 1), 0)

.
.
.

Case ""
'Dummy Case
Case Else
MsgBox Selection(cntrarray) & "Not Found When Uploading the EOS Plan", vbOKOnly
End Select
DoEvents
Next

'Update the record
Let strErrMsg = "Performing record update."
rstADO.Update
DoEvents

ExitSub:
' Perform Clean-up
Let strErrMsg = "Closing the DB."
rstADO.Close
Set rstADO = Nothing
DoEvents
cn.Close
Set cn = Nothing
DoEvents

'Presentation Management
Range("SameDayBagResetOwner").Activate
Call ToggleHideUnhideDataSheets("Hide")
MsgBox "End of Shift Upload Complete.", vbOKOnly, "RTS SPT Update"
If Err.Number = 0 Then Exit Sub

ErrorMessage:
Let strErrMsg = "An Error Occurred. Error: " & Err.Number & " - Descr: " & Err.Description & " - " & strErrMsg
MsgBox strErrMsg, vbOKOnly, "Error Handler"

On Error Resume Next

' Perform Clean-up
Set rstADO = Nothing
Set cn = Nothing

'Presentation Management
Call ToggleHideUnhideDataSheets("Hide")
End Sub
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Sort by date Sort by votes
What little experience I've had between Access, Excel and SP had to do with automation. AFAIK, SP is basically a web server, and Access never did play well with web based db's. Perhaps this will help, or you can explore the topic to see if you're on the wrong track.

Build and publish an Access database to SharePoint - Microsoft Support

support.microsoft.com support.microsoft.com
Don't miss the note labeled "important".

You should post more than a few lines of code within code tags (use vba button on posting toolbar) to maintain indentation and readability. I'm too old and cranky to even bother reading code like that.;)

EDIT - also see Daniel's post on the subject. He's been around a long time and knows his stuff.
 
Last edited:
Upvote 0
Solution
Micron said:
What little experience I've had between Access, Excel and SP had to do with automation. AFAIK, SP is basically a web server, and Access never did play well with web based db's. Perhaps this will help, or you can explore the topic to see if you're on the wrong track.

Build and publish an Access database to SharePoint - Microsoft Support

support.microsoft.com support.microsoft.com
Don't miss the note labeled "important".

You should post more than a few lines of code within code tags (use vba button on posting toolbar) to maintain indentation and readability. I'm too old and cranky to even bother reading code like that.;)

EDIT - also see Daniel's post on the subject. He's been around a long time and knows his stuff.
Click to expand...
VBA Code:
Micron said:
What little experience I've had between Access, Excel and SP had to do with automation. AFAIK, SP is basically a web server, and Access never did play well with web based db's. Perhaps this will help, or you can explore the topic to see if you're on the wrong track.

Build and publish an Access database to SharePoint - Microsoft Support

support.microsoft.com support.microsoft.com
Don't miss the note labeled "important".

You should post more than a few lines of code within code tags (use vba button on posting toolbar) to maintain indentation and readability. I'm too old and cranky to even bother reading code like that.;)

EDIT - also see Daniel's post on the subject. He's been around a long time and knows his stuff.
Click to expand...

Thank you, Micron. Daniel's post was great for getting the ACCDB published to the SharePoint server; in that train of thought, I was able to find a MS post that was helpful in bringing the project home.

VBA Code: 
Option Explicit

Sub updateAccess(blnEndofShift As Boolean)
' Declarations
    Dim cn As ADODB.Connection
    Dim rstADO As ADODB.Recordset
    Dim wbWorkbook As Workbook
    Dim wsWorksheet As Worksheet
    Dim rngName As Range
    Dim dynArrayStr() As String
    Dim tmTimeKeeper As Date
    Dim intArrayMax As Integer
    Dim intCntr As Integer
    Dim intFind1 As Integer
    Dim intFind2 As Integer
    Dim strErrMsg As String
    Dim strFound As String
    Dim sProduct As String
    Dim cPrice As String
    Dim strSQL As String
    
    Const strSharepointSite = "https://share..../"
    Const strSharepointListID = "{86E0CF44-76F1-4ECB-AC82-28A8D9918592}"
    Const strSharepointListName = "Data"
    
    Const cnstFindStr1 As String = "RTS"
    Const cnstFindStr2 As String = "Total"


    If Not blnEndofShift Then Exit Sub

'Presentation Management
    Call ToggleHideUnhideDataSheets("Show")

'Resume Next on an Error

    On Error GoTo ErrorMessage
    Let strErrMsg = ""

'Connection Declarations
    Let strErrMsg = "Connection"
    Set cn = New ADODB.Connection
    cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;WSS;IMEX=0;RetrieveIds=Yes;DATABASE=" & strSharepointSite & ";LIST=" & strSharepointListID & ";"
    cn.Open
    
    On Error Resume Next
    
    If Err.Number = -2147467259 Then tmTimeKeeper = Now + TimeValue("00:01:00")
    
    Do While cn.State <> adStateOpen And Now <= tmTimeKeeper
        cn.Open
        DoEvents
        Application.Wait (Now + TimeValue("0:00:5"))
        If cn.State = adStateOpen Then
            Err.Clear
            Exit Do
        End If
    Loop
    
    If Not cn.State = adStateOpen Then
        MsgBox "Please try again.  The SharePoint server is locked at this time", vbOKCancel, , "DB Write Error"
        GoTo ExitSub
    End If
    
'Turn-off Resume Next
    On Error GoTo ErrorMessage

'Recordset Declaration
    
    Set rstADO = New ADODB.Recordset
    Let strErrMsg = "Opening DB"
    'rstADO.Open "RTS_SPT_Adoption_Data", cn, adOpenDynamic, adLockPessimistic, adCmdTable
    Let strSQL = "SELECT * FROM [" & strSharepointListName & "];"
    rstADO.Open strSQL, cn, adOpenStatic, adLockOptimistic, adCmdText
        ' https://learn.microsoft.com/en-us/sql/ado/guide/data/types-of-locks?view=sql-server-ver16
            'adLockBatchOptimistic
            'adLockOptimistic
            'adLockPessimistic
            'adLockReadOnly
            'adLockUnspecified
     

'Add a new record
    Let strErrMsg = "Adding a new record."
    rstADO.AddNew


 
    Set wbWorkbook = ThisWorkbook
    Set wsWorksheet = wbWorkbook.Sheets("parms")
    
    ' Load Station, DateTime Stamp, DS Reset Owner
    Let strErrMsg = "Updating fields in a record."
    
    Set wsWorksheet = wbWorkbook.Sheets("parms")
    rstADO!DeliveryStation = wsWorksheet.Range("DlvryStn")
    rstADO!DateTime = Now
    rstADO!Shift = "RTS"
    rstADO!StowBagReplenOwner = wsWorksheet.Range("StowBagReplenOwner")
    rstADO!DCAPInductOVPkgPct = wsWorksheet.Range("DCAP_Induct_OV_package")
    rstADO!AvgShipPerBag = wsWorksheet.Range("Avg_Shipments_per_Bag")
    
    ' Other Plan Parameters
    rstADO!StowBagReplenOwner = wsWorksheet.Range("StowBagReplenOwner")
    
    ' Load Core and PFSD Volume
    Set wsWorksheet = wbWorkbook.Sheets("PvA")
    
    rstADO!CoreVolumePlan = wsWorksheet.Range("E5")
    rstADO!CoreVolumeActual = wsWorksheet.Range("F5")
    rstADO!DispatchVolumePlan = wsWorksheet.Range("J5")
    rstADO!DispatchVolumeActual = wsWorksheet.Range("K5")
    rstADO!AdhocVolumePlan = wsWorksheet.Range("O5")
    rstADO!AdhocVolumeActual = wsWorksheet.Range("P5")
    rstADO!SWAVolumePlan = 0
    rstADO!SWAVolumeActual = 0
    rstADO!SameDayVolumePlan = wsWorksheet.Range("T5")
    rstADO!SameDayVolumeActual = wsWorksheet.Range("U5")
    rstADO!RTSVolumePlan = wsWorksheet.Range("Y5")
    rstADO!RTSVolumeActual = wsWorksheet.Range("Z5")
    rstADO!TotalVolumePlan = wsWorksheet.Range("AD5")
    rstADO!TotalVolumeActual = wsWorksheet.Range("AE5")
    rstADO!HistBagsLeftover = IIf(IsNumeric(wsWorksheet.Range("HistLeftoverBags")), wsWorksheet.Range("HistLeftoverBags"), 0)
    rstADO!HistAdhocVolume = IIf(IsNumeric(wsWorksheet.Range("HistAdhocVolume")), wsWorksheet.Range("HistAdhocVolume"), 0)
    
    'Find the columns that have the values sought
    wsWorksheet.Rows(3).Select
    Let strFound = Selection.Find(cnstFindStr1, lookat:=xlWhole, MatchCase:=False).AddressLocal
    Let intFind1 = Range(strFound).Column
    Let strFound = Selection.Find(cnstFindStr2, lookat:=xlWhole, MatchCase:=False).AddressLocal
    Let intFind2 = Range(strFound).Column
    
    'Begin preparation for processing the day's plan and actuals (PvA Tab)
    Let intArrayMax = wsWorksheet.Range("PvA_ProcessPaths").Count
    ReDim dynArrayStr(intArrayMax)
    For intCntr = 1 To intArrayMax
        wsWorksheet.Range("PvA_ProcessPaths").Activate
        If Selection(intCntr) <> "" Then
            Let dynArrayStr(intCntr) = Selection(intCntr)
        End If
    Next
    
    ' Load Plan Rates and Hours (Plan and Actual)
    Let intCntr = 0
    For intCntr = 1 To intArrayMax
        DoEvents
        Select Case Selection(intCntr)
            Case "Auto Scan Induct Loader"
                rstADO!AutoScanInductLoader_PlanRate = IIf(IsNumeric(Selection(intCntr).Offset(0, intFind2 - 1)), Selection(intCntr).Offset(0, intFind2 - 1), 0)
                rstADO!RTSAutoScanInductLoader_PlanHours = IIf(IsNumeric(Selection(intCntr).Offset(0, intFind1 - 2)), Selection(intCntr).Offset(0, intFind1 - 2), 0)
                rstADO!RTSAutoScanInductLoader_ActualHours = IIf(IsNumeric(Selection(intCntr).Offset(0, intFind1 - 1)), Selection(intCntr).Offset(0, intFind1 - 1), 0)
                rstADO!TotalAutoScanInductLoader_PlanHours = IIf(IsNumeric(Selection(intCntr).Offset(0, intFind2 - 2)), Selection(intCntr).Offset(0, intFind2 - 2), 0)
                rstADO!TotalAutoScanInductLoader_ActualHours = IIf(IsNumeric(Selection(intCntr).Offset(0, intFind2 - 1)), Selection(intCntr).Offset(0, intFind2 - 1), 0)
                
.
.
.
            Case ""
                'Dummy Case
            Case Else
                MsgBox Selection(intCntr) & "Not Found When Uploading the EOS Plan", vbOKOnly
            End Select
            DoEvents
        Next
    
    'Update the record
    Let strErrMsg = "Performing record update."
    rstADO.Update
    DoEvents

ExitSub:
    ' Perform Clean-up
    Let strErrMsg = "Closing the DB."
    rstADO.Close
    Set rstADO = Nothing
    DoEvents
    cn.Close
    Set cn = Nothing
    DoEvents
 
    'Presentation Management
    Range("SameDayBagResetOwner").Activate
    Call ToggleHideUnhideDataSheets("Hide")
    MsgBox "End of Shift Upload Complete.", vbOKOnly, "RTS SPT Update"
    If Err.Number = 0 Then Exit Sub
    
ErrorMessage:
    Let strErrMsg = "An Error Occurred.  Error: " & Err.Number & " - Descr:  " & Err.Description & " - " & strErrMsg
    MsgBox strErrMsg, vbOKOnly, "Error Handler"
    
    On Error Resume Next
     
     ' Perform Clean-up
    Set rstADO = Nothing
    Set cn = Nothing
 
    'Presentation Management
    Call ToggleHideUnhideDataSheets("Hide")
End Sub
 
Upvote 0
Glad I was able to help out just a bit. Thanks for the recognition.
 
Upvote 1
You must log in or register to reply here.

Similar threads

S
  • Solved
Accessing Sharepoint List from Excel/VBA using ADODB connection
Replies
3
Views
3K
RoryA
RoryA
D
  • Question
Database issue
2
Replies
12
Views
2K
Darren Smith
D
C
  • Question
Export Excel Data to Access Table or Query using Excel VBA
Replies
0
Views
3K
craigb1155
C
T
  • Question
Insert/Delete Columns issue via VBA
Replies
1
Views
692
Tdorman
T
D
  • Question
Excel data to Access
Replies
1
Views
1K
rondeondo
rondeondo

Forum statistics

Threads
1,216,500
Messages
6,131,016
Members
449,615
Latest member
Nic0la

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top