Hi all.



I have an access db with lists linked from sharepoint (yea I know, I did it years ago before I had access to an sql server and I have not converted it yet). I want to pull data into excel. The fastest method I found was to have vb excel run the query (against the sharepoint lists), return the results to a ado recordset, copy the recordset to a temp tab, convert the temp tab to a table, pull the table into Power Query, manipulate it, push the data to a new tab. This works well and fast.

I have put this "reference" db on every users c drive.

Question... When excl vb opens the db's query, the database locks. When I close the rs, the db unlocks and closes. I am just thinking ahead... While the db is locked (excel ado rs connection still open), I cannot run another query from excel to the same database. I am thinking of having multiple apps run queries from the same db.. but it looks like only 1 app can have 1 connection to the db at one time and anyother connection is refused. Here is my code from excel to do this for reference....
Code:
Public Function Pull_LZ_With_Access_Query(Optional project_number) As Boolean ' True = Good, False = Bad                                                                                'Optional Project number was used for debug.
Dim con As ADODB.Connection
Dim cmd As ADODB.Command
Dim prm As ADODB.Parameter
Dim rs As ADODB.Recordset
    
Dim i As Integer
Dim tab_name As String
Dim row_position As Long
Dim column_position As Long
Dim table_name As String


    Set con = New ADODB.Connection
    Set cmd = New ADODB.Command


    With con ' open db local if it lz is installed and db exists, else open from sharepoint
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Mode = adModeRead
        .CursorLocation = adUseClient
    End With
    On Error Resume Next
Application.StatusBar = " Pulling LZs from Local Database..."
DoEvents


    con.Open "c:\lz\LZ Sharepoint Tables.accde" 'open if local was installed with the landing zone installation
    If Err Then
        If Err = -2147467259 Then 'if lz is not installed then db will not be there either, so open from sharepoint.  Sharepoint open is slower than local
                                    ' or error is because local db is already opended and has a lock file ...
            Err.Clear
Application.StatusBar = " Pulling LZs from Sharepoint Database..."
DoEvents
            con.Open "//xxxxxxxxxxxxxxx/CPP Db for those without lz db installed locally/LZ Sharepoint Tables.accde"
            If Err Then
                Err.Clear
                On Error GoTo 0
                MsgBox "ERROR: Accessing Sharepoint Database...", vbCritical
                Pull_LZ_With_Access_Query = False
                Exit Function
            End If
        Else
            'some other error
            MsgBox "ERROR:  Cannot Pull LZ data...", vbCritical
            Err.Clear
            On Error GoTo 0
            Pull_LZ_With_Access_Query = False
            Exit Function
        End If
    End If


    With cmd ' if only 1 cpp is being created, then run parameter query.  If more then run all query
        .ActiveConnection = con
        .CommandText = "[CPP LZ Pull 2d) All Projects]"
        .CommandType = adCmdStoredProc
        'if you wanted to run a parameter query, this is how to setup
        'Set prm = .CreateParameter("ProjectNumber", adChar, adParamInput, 255, ArrayPrjNbr(rownumm)) 'ArrayPrjNbr(rownumm) is a global variable of current project being created
        '.Parameters.Append prm
    End With


    Set rs = New ADODB.Recordset
    rs.Open cmd, , adOpenStatic, adLockOptimistic
    If Not rs.EOF Then
        rs.MoveLast
        rs.MoveFirst
    End If


    tab_name = "LZ Data - VBA Pull"
    table_name = "LZPull - VBA"
    row_position = 6
    column_position = 1
    
    On Error Resume Next
    Sheets(tab_name).ListObjects(table_name).Delete
    'Sheets(tab_name).ListObjects(table_name).DataBodyRange.ClearContents
    
    On Error GoTo 0
    ' I had ot add this in because without making this tab visible, it messed up format on a different tab during the rs paste
    ThisWorkbook.Worksheets(tab_name).Visible = True
    ThisWorkbook.Worksheets(tab_name).Activate
    ThisWorkbook.Worksheets(tab_name).Cells(row_position + 1, column_position).CopyFromRecordset rs
    
    'Add headers
    For i = 1 To rs.Fields.Count
        ThisWorkbook.Worksheets(tab_name).Cells(row_position, i + column_position - 1) = rs.Fields(i - 1).Name
    Next i
    
    Call Convert_Range_To_Table(table_name, tab_name, row_position, column_position)
 
    rs.Close
    con.Close


    Set cmd = Nothing
    Set rs = Nothing
    Set prm = Nothing
    Set con = Nothing
    Pull_LZ_With_Access_Query = True
    
    ThisWorkbook.Worksheets(tab_name).Visible = xlSheetVeryHidden
    
End Function

Thanks
Steve
Harriburg, PA