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