Remove or Bypass the 'File Reservation' Dialogue?

[phendrena]

Hi,

Is it possible to bypass, skip or ignore the File Reservation dialogue to allow more than one user the ability to modify a document without 'sharing' the workbook?

The reason is as follows :-
I have a workbook that is used by several users at one time, this workbook is password protected so users can't modify anything.
It is perfectly fine for them to open it as Read-Only as the excel workbook only serves as a front-end data entry system as all the actual data is held in access.
Under certain controlled circumstances, multiple users would need the ability to amend the various lookup tables. To this i need the ability to bypass the 'file reservation' dialogue.

I have the following code which changes the permission of the workbook from Read-Only to Read/Write and visa-versa.

'--- Read/Write
ActiveWorkbook.ChangeFileAccess Mode:=xlReadWrite, WritePassword:="password"
'--- Read Only
ActiveWorkbook.ChangeFileAccess Mode:=xlReadOnly, WritePassword:="password"

However, when you run the code to change it from read-only the 'file reservation' dialogue appears.

Is anyone able to help with this query?

[Bob Phillips]

Why aren't the lookup tables held in Access as well?

[phendrena]

Why aren't the lookup tables held in Access as well?The lookup tables hold the data to populate various listboxes, comboboxes and perform validation checks against the windows logon username.

I thought it'd be far easier to keep these held on the spreadsheet rather than pulling the data from access.

[Bob Phillips]

Personally, I would store themk in Access and load them at workbook open. The display spreadsheet should hold no data in my view of these things.

[phendrena]

Personally, I would store themk in Access and load them at workbook open. The display spreadsheet should hold no data in my view of these things.Would you then load them into a worksheet? I could get quite tricky as i use a of name ranges (standard and dynamic).

[Bob Phillips]

I would, I do. What you mention is not a problem, create the range names dynamically, after loading into the worksheet.

Using ADO and CopyFromRecordset you have a simple means of getting the data and dropping into a worksheet.

[Bob Phillips]

You can maintain the data either directly in Access, or build an Excel/VB front-en d to manage that.

[phendrena]

I would, I do. What you mention is not a problem, create the range names dynamically, after loading into the worksheet.

Using ADO and CopyFromRecordset you have a simple means of getting the data and dropping into a worksheet.Would you be able to provide an example please, i'm not sure how you would create the named range after loading the data into the worksheet and i'm not 100% on actually getting the data into a worksheet.

Strangely though......


You can maintain the data either directly in Access, or build an Excel/VB front-en d to manage that.This i can do. I already have a record search and update in place so that could be adjusted quite easily.

[Bob Phillips]

here is a very simple example



Sub GetData()
Const adOpenForwardOnly As Long = 0
Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim RS As Object
Dim sConnect As String
Dim sSQL As String
Dim LastRow As Long

sConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & "c:\test\bob.mdb"

sSQL = "SELECT * From Contacts"
Set RS = CreateObject("ADODB.Recordset")
RS.Open sSQL, sConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText

' Check to make sure we received data.
If Not RS.EOF Then
Range("H1").Value = "First Name"
Range("I1").Value = "Last Name"
Range("J1").Value = "Phone"
Range("K1").Value = "County"
Range("H2").CopyFromRecordset RS

LastRow = Range("H1").End(xlDown).Row
Range("H1").Resize(LastRow, 4).Name = "myTable"
Else
MsgBox "No records returned.", vbCritical
End If

RS.Close
Set RS = Nothing
End Sub

[phendrena]

Hi xld,

Thanks for the reply and ongoing support with this one.
I have modified the code to point to my database and set the column headers appropriate, however I am now getting the following error :-

'Class doesn't support Automation'

Debug highlights the following : 'ws.Range("H2").CopyFromRecordset RS'

Sub GetData()
Const adOpenForwardOnly As Long = 0
Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim RS As Object
Dim sConnect As String
Dim sSQL As String
Dim LastRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Lookups")
sConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & "S:\BTeams\Ford\DST\Call Log Database\Database\DST Database.mdb"
sSQL = "SELECT * From StaffList"
Set RS = CreateObject("ADODB.Recordset")
RS.Open sSQL, sConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText
' Check to make sure we received data.
If Not RS.EOF Then
ws.Range("H1").Value = "CustomerManager"
ws.Range("I1").Value = "Site"
ws.Range("J1").Value = "EmailSubject"
ws.Range("K1").Value = "TeamLeader"
ws.Range("L1").Value = "TCM"
ws.Range("H2").CopyFromRecordset RS

LastRow = ws.Range("H1").End(xlDown).Row
ws.Range("H1").Resize(LastRow, 5).Name = "StaffList"
Else
MsgBox "No records returned.", vbCritical
End If
RS.Close
Set RS = Nothing
End Sub

The code has been placed into a normal module and run from there.

Do you have any suggestions?

Thanks,

[Bob Phillips]

No, I am lost on that one. Any chance that you can post the database and workbook?

[phendrena]

Sure.
These are examples not the actually files as they would require massive stripping, however they error just the same.You'll need to change the filename and path accordingly.

[Bob Phillips]

I have just run it and I don't get that problem.

[phendrena]

Hmmmm..... a problem with Excel '97 perhaps?

[Bob Phillips]

I have just remembered, you have Excel 97? CopyRecordset was not available to 97. We could use GetRows into an array and dump that, but you have nulls in the data. Can they be removed in your database?

[Bob Phillips]

Try this



Sub GetData()
Const adOpenForwardOnly As Long = 0
Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim RS As Object
Dim sConnect As String
Dim sSQL As String
Dim LastRow As Long
Dim ary As Variant
Dim i As Long
Dim j As Long

Dim ws As Worksheet
Set ws = Worksheets("Lookups")

sConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & "S:\BTeams\Ford\DST\Call Log Database\Database\DST Database.mdb"

sSQL = "SELECT * From StaffList"
Set RS = CreateObject("ADODB.Recordset")
RS.Open sSQL, sConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText

' Check to make sure we received data.
If Not RS.EOF Then
ws.Range("H1").Value = "CustomerManager"
ws.Range("I1").Value = "Site"
ws.Range("J1").Value = "EmailSubject"
ws.Range("K1").Value = "TeamLeader"
ws.Range("L1").Value = "TCM"
ary = RS.getrows
For i = LBound(ary, 1) To UBound(ary, 1)

For j = LBound(ary, 2) To UBound(ary, 2)

If IsNull(ary(i, j)) Then ary(i, j) = ""
Next j
Next i
ws.Range("H2").Resize(UBound(ary, 2), UBound(ary, 1)) = Application.Transpose(ary)
'ws.Range ("H2") =
LastRow = ws.Range("H1").End(xlDown).Row
ws.Range("H2").Resize(LastRow, 5).Name = "myTable"
Else
MsgBox "No records returned.", vbCritical
End If

RS.Close
Set RS = Nothing
End Sub

[phendrena]

If by nulls you mean blank fields, then there will be some blank fields as not all TeamLeaders have an associated TCM.
The code does work nicely, but doesn't import the TCM field. I assume this is due to the blanks?

Edit : The code also misses off the last record when it brings the data into excel.

[Bob Phillips]

No, not the blanks, it is down to my crap code, I was mishandling the array size (same problem on last record).

This should be better



Sub GetData()
Const adOpenForwardOnly As Long = 0
Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim RS As Object
Dim sConnect As String
Dim sSQL As String
Dim LastRow As Long
Dim ary As Variant
Dim i As Long
Dim j As Long

Dim ws As Worksheet
Set ws = Worksheets("Lookups")

sConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & "C:\Example1.mdb"

sSQL = "SELECT * From StaffList"
Set RS = CreateObject("ADODB.Recordset")
RS.Open sSQL, sConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText

' Check to make sure we received data.
If Not RS.EOF Then
ws.Range("H1").Value = "CustomerManager"
ws.Range("I1").Value = "Site"
ws.Range("J1").Value = "EmailSubject"
ws.Range("K1").Value = "TeamLeader"
ws.Range("L1").Value = "TCM"
ary = RS.getrows
For i = LBound(ary, 1) To UBound(ary, 1)

For j = LBound(ary, 2) To UBound(ary, 2)

If IsNull(ary(i, j)) Then ary(i, j) = ""
Next j
Next i
ws.Range("H2").Resize(UBound(ary, 2) - LBound(ary, 2) + 1, UBound(ary, 1) - LBound(ary, 1) + 1) = Application.Transpose(ary)
'ws.Range ("H2") =
LastRow = ws.Range("H1").End(xlDown).Row
ws.Range("H2").Resize(LastRow, 5).Name = "myTable"
Else
MsgBox "No records returned.", vbCritical
End If

RS.Close
Set RS = Nothing
End Sub

[phendrena]

Nice one xld.
I wouldn't call your code crap though, mine yes, yours no :D
I assume i can modify the sSQL statement to include other standard SQL statements, for example to split the staff list into alphabetical sections by using WHERE and LIKE etc.

I'm not going to mark this thread as solved as it could be misleading as we went off from the actual subject.

[Bob Phillips]

Absolutely. You can modify the SQL, filter the recordset, or do it in the spreadsheet. SQL is the obvious choice, but you have options.

[phendrena]

Ok, here comes the fun question.
Using your code, with a slight modification to the SQL i can get the different name ranges to populate correctly.
sSQL = "SELECT * FROM [StaffList] " & _
"WHERE [StaffList].[CustomerManager] LIKE '" & "A" & "%'"
'...
'....
'.....
If Not RS.EOF Then
ws.Range("A1").Value = "CustomerManager"
ws.Range("B1").Value = "Site"
ws.Range("C1").Value = "EmailSubject"
ws.Range("D1").Value = "TeamLeader"
ws.Range("E1").Value = "TCM"

However, I don't really fancy adding 26 (A to Z) almost identical routines in the module. Would you be able to suggest a better way to do it?

I did think about looping through the code, but as well as modifing the SQL statement i'd also need to change the ws.range where i want the data to go, as such it the code would still be rather chunky.

Is there a somewhat less chunky way to do it?

Cheers,

[Bob Phillips]

Wouldn't something like this work


For i = 1 To 26

sSQL = "SELECT * FROM [StaffList] " & _
"WHERE [StaffList].[CustomerManager] LIKE '" & CHR(i +64) & "%'"
'...
'....
'.....
If Not RS.EOF Then
ws.Cells(1, i*5 -4).Value = "CustomerManager"
ws.Cells(1, i*5 -4).Offset(0, 1).Value = "Site"
ws.Cells(1, i*5 -4).Offset(0, 2).Value = "EmailSubject"
ws.Cells(1, i*5 -4).Offset(0, 3).Value = "TeamLeader"
ws.Cells(1, i*5 -4).Offset(0, 4).Value = "TCM"
'...
Next i

[phendrena]

Indeed it would and does.
Of course I now need the rest of the data to populate correctly and also assign the Range Name (StaffA, StaffB etc).
For k = 1 To 26
sSQL = "SELECT * FROM [StaffList] " & _
"WHERE [StaffList].[CustomerManager] LIKE '" & Chr(k + 64) & "%'"

Set RS = CreateObject("ADODB.Recordset")
RS.Open sSQL, sConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText
' Check to make sure we received data.
If Not RS.EOF Then
ws.Cells(1, k * 5 - 4).Value = "CustomerManager"
ws.Cells(1, k * 5 - 4).Offset(0, 1).Value = "Site"
ws.Cells(1, k * 5 - 4).Offset(0, 2).Value = "EmailSubject"
ws.Cells(1, k * 5 - 4).Offset(0, 3).Value = "TeamLeader"
ws.Cells(1, k * 5 - 4).Offset(0, 4).Value = "TCM"

ary = RS.getrows
For i = LBound(ary, 1) To UBound(ary, 1)

For j = LBound(ary, 2) To UBound(ary, 2)

If IsNull(ary(i, j)) Then ary(i, j) = ""
Next j
Next i
ws.Range("A2").Resize(UBound(ary, 2) - LBound(ary, 2) + 1, UBound(ary, 1) - LBound(ary, 1) + 1) = Application.Transpose(ary)
'ws.Range ("A2") =
LastRow = ws.Range("A1").End(xlDown).Row
ws.Range("A2").Resize(LastRow, 5).Name = "StaffA"
' Else
' MsgBox "No records returned.", vbCritical
End If
RS.Close
Set RS = Nothing
Next k

[Bob Phillips]

I don't think that you need to worry about the ary, it will only contain your required items, so you only have to consider the cell references



For k = 1 To 26
sSQL = "SELECT * FROM [StaffList] " & _
"WHERE [StaffList].[CustomerManager] LIKE '" & Chr(k + 64) & "%'"

Set RS = CreateObject("ADODB.Recordset")
RS.Open sSQL, sConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText
' Check to make sure we received data.
If Not RS.EOF Then
ws.Cells(1, k * 5 - 4).Value = "CustomerManager"
ws.Cells(1, k * 5 - 4).Offset(0, 1).Value = "Site"
ws.Cells(1, k * 5 - 4).Offset(0, 2).Value = "EmailSubject"
ws.Cells(1, k * 5 - 4).Offset(0, 3).Value = "TeamLeader"
ws.Cells(1, k * 5 - 4).Offset(0, 4).Value = "TCM"

ary = RS.getrows
For i = LBound(ary, 1) To UBound(ary, 1)

For j = LBound(ary, 2) To UBound(ary, 2)

If IsNull(ary(i, j)) Then ary(i, j) = ""
Next j
Next i
ws.Cells(2, k * 5 - 4).Resize(UBound(ary, 2) - LBound(ary, 2) + 1, UBound(ary, 1) - LBound(ary, 1) + 1) = Application.Transpose(ary)
'ws.Cells(2, k * 5 - 4) =
LastRow = ws.Cells(1, k * 5 - 4).End(xlDown).Row
ws.Cells(2, k * 5 - 4).Resize(LastRow, 5).Name = "StaffA"
' Else
' MsgBox "No records returned.", vbCritical
End If
RS.Close
Set RS = Nothing
Next k


BTW I assume this issues 26 queries. Have you thought of issuing just one query and filtering the recordset?

[phendrena]

BTW I assume this issues 26 queries. Have you thought of issuing just one query and filtering the recordset?
Yes this does issue and create 26 queries with 26 seperate named ranges. I have it setup like this as i have a listbox where people can filter a staff list by the first name.
I could create one long staff list and filter the list based on the selected criteria as pulling the data from a seperate source has also solved one other issue that I had.
I'll ponder over that one :D

Thanks for all the help xld
:beerchug:

[phendrena]

Xld,

Once final (i hope) question regarding the code.
If it doesn't come across any data that starts with a particualr letter, for example Q, it doesn't input any data as you'd expect but it does skip 5 columns.

Is there anyway that I can still get the code to insert the column headings and also the second row sub-heading?

Here's my current code :-

Sub GetStaffList()
Const adOpenForwardOnly As Long = 0
Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim RS As Object
Dim sConnect As String
Dim sSQL As String
Dim LastRow As Long
Dim ary As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim ws As Worksheet
Set ws = Worksheets("Lookups")
sConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & "C:\Database.mdb"
For k = 1 To 26
sSQL = "SELECT * FROM [StaffList] " & _
"WHERE [StaffList].[CustomerManager] LIKE '" & Chr(k + 64) & "%'"

Set RS = CreateObject("ADODB.Recordset")
RS.Open sSQL, sConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText
' Check to make sure we received data.
If Not RS.EOF Then
' --- Row Headings
ws.Cells(1, k * 5 - 4).Value = "CustomerManager"
ws.Cells(1, k * 5 - 4).Offset(0, 1).Value = "Site"
ws.Cells(1, k * 5 - 4).Offset(0, 2).Value = "EmailSubject"
ws.Cells(1, k * 5 - 4).Offset(0, 3).Value = "TeamLeader"
ws.Cells(1, k * 5 - 4).Offset(0, 4).Value = "TCM"
' --- Sub Heading
ws.Cells(2, k * 5 - 4).Value = "-- " & Chr(k + 64) & " --"

ary = RS.getrows
For i = LBound(ary, 1) To UBound(ary, 1)

For j = LBound(ary, 2) To UBound(ary, 2)

If IsNull(ary(i, j)) Then ary(i, j) = ""
Next j
Next i
ws.Cells(3, k * 5 - 4).Resize(UBound(ary, 2) - LBound(ary, 2) + 1, UBound(ary, 1) - LBound(ary, 1) + 1) = Application.Transpose(ary)
'ws.Cells(2, k * 5 - 4) =
LastRow = ws.Cells(1, k * 5 - 4).End(xlDown).Row
ws.Cells(2, k * 5 - 4).Resize(LastRow, 5).Name = "Staff" & Chr(k + 64)
' Else
' MsgBox "No records returned.", vbCritical
End If
RS.Close
Set RS = Nothing

Call sUpdate(k) '-- Code is now contained within a userform to show import progress

Next k

End SubThanks,

[Bob Phillips]

Sub GetStaffList()
Const adOpenForwardOnly As Long = 0
Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim RS As Object
Dim sConnect As String
Dim sSQL As String
Dim LastRow As Long
Dim RowIndex As Long
Dim ary As Variant
Dim i As Long, j As Long, k As Long
Dim ws As Worksheet

Set ws = Worksheets("Lookups")
sConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & "C:\Database.mdb"

RowIndex = 1
For k = 1 To 26

sSQL = "SELECT * FROM [StaffList] " & _
"WHERE [StaffList].[CustomerManager] LIKE '" & Chr(k + 64) & "%'"

Set RS = CreateObject("ADODB.Recordset")
RS.Open sSQL, sConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText
' Check to make sure we received data.
If Not RS.EOF Then
' --- Row Headings
ws.Cells(1, RowIndex * 5 - 4).Value = "CustomerManager"
ws.Cells(1, RowIndex * 5 - 4).Offset(0, 1).Value = "Site"
ws.Cells(1, RowIndex * 5 - 4).Offset(0, 2).Value = "EmailSubject"
ws.Cells(1, RowIndex * 5 - 4).Offset(0, 3).Value = "TeamLeader"
ws.Cells(1, RowIndex * 5 - 4).Offset(0, 4).Value = "TCM"
' --- Sub Heading
ws.Cells(2, RowIndex * 5 - 4).Value = "-- " & Chr(RowIndex + 64) & " --"

ary = RS.getrows
For i = LBound(ary, 1) To UBound(ary, 1)

For j = LBound(ary, 2) To UBound(ary, 2)

If IsNull(ary(i, j)) Then ary(i, j) = ""
Next j
Next i

ws.Cells(3, RowIndex * 5 - 4).Resize(UBound(ary, 2) - LBound(ary, 2) + 1, UBound(ary, 1) - LBound(ary, 1) + 1) = Application.Transpose(ary)
'ws.Cells(2, rowindex * 5 - 4) =
LastRow = ws.Cells(1, RowIndex * 5 - 4).End(xlDown).Row
ws.Cells(2, RowIndex * 5 - 4).Resize(LastRow, 5).Name = "Staff" & Chr(RowIndex + 64)
' Else
' MsgBox "No records returned.", vbCritical

RowIndex = RowIndex + 1
End If
RS.Close
Set RS = Nothing

Call sUpdate(k) '-- Code is now contained within a userform to show import progress

Next k

End Sub

[phendrena]

Thanks for the amended code xld.

It's not quite working as expected though.

I would like it to :-
Add row headings and sub heading to all appropriate columns.
It also needs to keep the blank spaces below the columns to ensure that the sub-headings align correctly.

Each block is 5 columns wide.
Row 1 has 5 column headers
Row 2 has the alphabetically index (a, b, c, d etc)

So even if there isn't any data for a particular letter in the database it should still fill all the column headers and sub-headers.

So, I've slightly amended your original code, it's probably not the most elegant but it's the best i could figure out :

Sub GetStaffList()
Const adOpenForwardOnly As Long = 0
Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Dim RS As Object
Dim sConnect As String
Dim sSQL As String
Dim LastRow As Long
Dim ary As Variant
Dim i As Long, j As Long, k As Long

Dim ws As Worksheet
Set ws = Worksheets("Lookups")
sConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & "S:\BTeams\Ford\DST\Call Log Database\Database\DST Database.mdb"


'-- Set Heading / Sub-Heading first
For k = 1 To 26
ws.Cells(1, k * 5 - 4).Value = "CustomerManager"
ws.Cells(1, k * 5 - 4).Offset(0, 1).Value = "Site"
ws.Cells(1, k * 5 - 4).Offset(0, 2).Value = "EmailSubject"
ws.Cells(1, k * 5 - 4).Offset(0, 3).Value = "TeamLeader"
ws.Cells(1, k * 5 - 4).Offset(0, 4).Value = "TCM"
' --- Sub Heading
ws.Cells(2, k * 5 - 4).Value = "-- " & Chr(k + 64) & " --"
Next k

For k = 1 To 26
sSQL = "SELECT * FROM [StaffList] " & _
"WHERE [StaffList].[CustomerManager] LIKE '" & Chr(k + 64) & "%'"

Set RS = CreateObject("ADODB.Recordset")
RS.Open sSQL, sConnect, adOpenForwardOnly, _
adLockReadOnly, adCmdText

' Check to make sure we received data.
If Not RS.EOF Then

ary = RS.getrows
For i = LBound(ary, 1) To UBound(ary, 1)

For j = LBound(ary, 2) To UBound(ary, 2)

If IsNull(ary(i, j)) Then ary(i, j) = ""
Next j
Next i

ws.Cells(3, k * 5 - 4).Resize(UBound(ary, 2) - LBound(ary, 2) + 1, UBound(ary, 1) - LBound(ary, 1) + 1) = Application.Transpose(ary)
LastRow = ws.Cells(1, k * 5 - 4).End(xlDown).Row
ws.Cells(2, k * 5 - 4).Resize(LastRow, 5).Name = "Staff" & Chr(k + 64)
End If
RS.Close
Set RS = Nothing

Call sUpdate(k) '-- Code is now contained within a userform to show import progress

Next k

End Sub
I should've thought of doing this first before pesting you again.

I couldn't have done this without your help though.

Many thanks xld :beerchug: