Bonjour,
J'utilise une fonction ADO trouvée sur Internet pour aller chercher des données dans un workbook fermé (que j'appellerai base).
Elle fonctionne parfaitement, le seul petit souci c'est que lorsque beaucoup d'utilisateurs travaillent en même temps avec cette fonction consultation, pour créer le recordset elle ouvre la base chez l'utilisateur. Cela crée une réaction en cascade chez tout le monde, qui fait qu'elle se retrouve ouverte en lecture seule chez tous les autres, et du coup impossible d'écrire via d'autres macro. Cela n'arrive pas tout le temps, mais il suffit que tout le monde bosse en même temps, ou que le serveur où est situé la base soit un peu lent et les consultations rentrent en conflit et forcent son ouverture chez tout le monde.
Je voudrais donc modifier la fonction pour que si le workbook où il y a la base est déjà sollicité, qu'il ne soit pas ouvert avec message d'erreur, ou alors ouvert en lecture seule par défaut puis refermée immédiatement.
Merci par avance de votre aide.
Voici la fonction :
J'utilise une fonction ADO trouvée sur Internet pour aller chercher des données dans un workbook fermé (que j'appellerai base).
Elle fonctionne parfaitement, le seul petit souci c'est que lorsque beaucoup d'utilisateurs travaillent en même temps avec cette fonction consultation, pour créer le recordset elle ouvre la base chez l'utilisateur. Cela crée une réaction en cascade chez tout le monde, qui fait qu'elle se retrouve ouverte en lecture seule chez tous les autres, et du coup impossible d'écrire via d'autres macro. Cela n'arrive pas tout le temps, mais il suffit que tout le monde bosse en même temps, ou que le serveur où est situé la base soit un peu lent et les consultations rentrent en conflit et forcent son ouverture chez tout le monde.
Je voudrais donc modifier la fonction pour que si le workbook où il y a la base est déjà sollicité, qu'il ne soit pas ouvert avec message d'erreur, ou alors ouvert en lecture seule par défaut puis refermée immédiatement.
Merci par avance de votre aide.
Voici la fonction :
Code:
Option Explicit
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long
' Create the connection string.
If Header = False Then
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
End If
Else
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes"";"
End If
End If
If SourceSheet = "" Then
' workbook level name
szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
' worksheet level name or range
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If
On Error GoTo SomethingWrong
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1
' Check to make sure we received data and copy the data
If Not rsData.EOF Then
If Header = False Then
TargetRange.Cells(1, 1).CopyFromRecordset rsData
Else
'Add the header cell in each column if the last argument is True
If UseHeaderRow Then
For lCount = 0 To rsData.Fields.Count - 1
TargetRange.Cells(1, 1 + lCount).Value = _
rsData.Fields(lCount).Name
Next lCount
TargetRange.Cells(2, 1).CopyFromRecordset rsData
Else
TargetRange.Cells(1, 1).CopyFromRecordset rsData
End If
End If
Else
MsgBox "No records returned from : " & SourceFile, vbCritical
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub
SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function Array_Sort(ArrayList As Variant) As Variant
Dim aCnt As Integer, bCnt As Integer
Dim tempStr As String
For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1
For bCnt = aCnt + 1 To UBound(ArrayList)
If ArrayList(aCnt) > ArrayList(bCnt) Then
tempStr = ArrayList(bCnt)
ArrayList(bCnt) = ArrayList(aCnt)
ArrayList(aCnt) = tempStr
End If
Next bCnt
Next aCnt
Array_Sort = ArrayList
End Function