Chercher de l'info sur fichier ouvert

Le
Denys
Bonjour à tous,

Sur le site de Frédéric Sigonneau, j'ai pris les macros suivantes me
permettant d'aller chercher de l'info dans un fichier fermé de façon
très rapide. Cependant, cela ne fonctionne pas si le fichier est
ouvert.

Ma question est: est-il possible d'aller chercher de l'info sur une
page spécifique même si le fichier est ouvert? Voici les instructions
(modifiées pour ma cause) provenant du site de Frédéric Sigonneau:

Sub LitEmployee()
Dim Msg, Style, Title, Fichier As String
Fichier = "V:Daily Tasks" & ActiveSheet.Range("B1").Value & ".xls"
'Nom de l'employé en B1
If IsFileOpen(Fichier) Then
MsgBox "" & ActiveSheet.Range("B1").Value & "'s file is already in
use" & Chr(13) & "Please try later"
Exit Sub
'End If
Dim Fich$, Arr
Fich = "V:Daily Tasks" & ActiveSheet.Range("B1").Value & ".xls"

'récup des données à partir de l'adresse d'une plage de cellules
GetExternalData Fich, "Daily tasks", "A2:G5000", False, Arr

With ActiveSheet
.Range("A2", .Cells(UBound(Arr, 1), UBound(Arr, 2))).Value = Arr
End With

End Sub


'Must have the Microsoft Activex Data Objects 2.0 Library
'in the tools-referencein the VBA section
Sub GetExternalData(srcFile As String, _
srcSheet As String, _
srcRange As String, _
TTL As Boolean, _
outArr As Variant)
Dim myConn As ADODB.Connection, myCmd As ADODB.Command
Dim HDR As String, myRS As ADODB.Recordset, RS_n As Integer, RS_f As
Integer
Dim Arr

Set myConn = New ADODB.Connection
If TTL = True Then HDR = "Yes" Else HDR = "No"
myConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & srcFile & ";" & _
"Extended Properties=""Excel 8.0;" & _
"HDR=" & HDR & ";IMEX=1;"""
Set myCmd = New ADODB.Command
myCmd.ActiveConnection = myConn
If srcSheet = "" _
Then myCmd.CommandText = "SELECT * from `" & srcRange & "`" _
Else myCmd.CommandText = "SELECT * from `" & srcSheet & "$" &
srcRange & "`"
Set myRS = New ADODB.Recordset
myRS.Open myCmd, , adOpenKeyset, adLockOptimistic
ReDim Arr(1 To myRS.RecordCount, 1 To myRS.Fields.Count)
myRS.MoveFirst
Do While Not myRS.EOF
For RS_n = 1 To myRS.RecordCount 'lignes
For RS_f = 0 To myRS.Fields.Count - 1 'colonnes
Arr(RS_n, RS_f + 1) = myRS.Fields(RS_f).Value
Next
myRS.MoveNext
Next
Loop
myConn.Close
Set myRS = Nothing
Set myCmd = Nothing
Set myConn = Nothing

outArr = Arr

End Sub

Function IsFileOpen(filename As String)
Dim filenum As Integer, errnum As Integer

On Error Resume Next
filenum = FreeFile()
Open filename For Input Lock Read As #filenum
Close filenum
errnum = Err
On Error GoTo 0
Select Case errnum
Case 0
IsFileOpen = False
Case 70
IsFileOpen = True
Case Else
'Error errnum
End Select
End Function

Merci

Denys
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
MichDenis
Le #5002981
| Cependant, cela ne fonctionne pas si le fichier est ouvert.

| 'Must have the Microsoft Activex Data Objects 2.0 Library

Si tu as utilisé cette bibliothèque comme indiquée dans ta procédure,
effectivement, tu ne peux pas exécuter une requête si le classeur est
ouvert. Cependant, c'est un bug bien connu de cette bibliothèque !

Pour solutionner ton problème, si tu as accès à la même bibliothèque
du même nom version 2.8, tu n'éprouvera pas ce problème. J'ignore
à partir de quelle version, microsoft a corrigé le problème. Tu fais
un test en cochant tour à tour une version... tu verras bien.




"Denys"
Bonjour à tous,

Sur le site de Frédéric Sigonneau, j'ai pris les macros suivantes me
permettant d'aller chercher de l'info dans un fichier fermé de façon
très rapide. Cependant, cela ne fonctionne pas si le fichier est
ouvert.

Ma question est: est-il possible d'aller chercher de l'info sur une
page spécifique même si le fichier est ouvert? Voici les instructions
(modifiées pour ma cause) provenant du site de Frédéric Sigonneau:

Sub LitEmployee()
Dim Msg, Style, Title, Fichier As String
Fichier = "V:Daily Tasks" & ActiveSheet.Range("B1").Value & ".xls"
'Nom de l'employé en B1
If IsFileOpen(Fichier) Then
MsgBox "" & ActiveSheet.Range("B1").Value & "'s file is already in
use" & Chr(13) & "Please try later"
Exit Sub
'End If
Dim Fich$, Arr
Fich = "V:Daily Tasks" & ActiveSheet.Range("B1").Value & ".xls"

'récup des données à partir de l'adresse d'une plage de cellules
GetExternalData Fich, "Daily tasks", "A2:G5000", False, Arr

With ActiveSheet
.Range("A2", .Cells(UBound(Arr, 1), UBound(Arr, 2))).Value = Arr
End With

End Sub


'Must have the Microsoft Activex Data Objects 2.0 Library
'in the tools----reference---in the VBA section
Sub GetExternalData(srcFile As String, _
srcSheet As String, _
srcRange As String, _
TTL As Boolean, _
outArr As Variant)
Dim myConn As ADODB.Connection, myCmd As ADODB.Command
Dim HDR As String, myRS As ADODB.Recordset, RS_n As Integer, RS_f As
Integer
Dim Arr

Set myConn = New ADODB.Connection
If TTL = True Then HDR = "Yes" Else HDR = "No"
myConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & srcFile & ";" & _
"Extended Properties=""Excel 8.0;" & _
"HDR=" & HDR & ";IMEX=1;"""
Set myCmd = New ADODB.Command
myCmd.ActiveConnection = myConn
If srcSheet = "" _
Then myCmd.CommandText = "SELECT * from `" & srcRange & "`" _
Else myCmd.CommandText = "SELECT * from `" & srcSheet & "$" &
srcRange & "`"
Set myRS = New ADODB.Recordset
myRS.Open myCmd, , adOpenKeyset, adLockOptimistic
ReDim Arr(1 To myRS.RecordCount, 1 To myRS.Fields.Count)
myRS.MoveFirst
Do While Not myRS.EOF
For RS_n = 1 To myRS.RecordCount 'lignes
For RS_f = 0 To myRS.Fields.Count - 1 'colonnes
Arr(RS_n, RS_f + 1) = myRS.Fields(RS_f).Value
Next
myRS.MoveNext
Next
Loop
myConn.Close
Set myRS = Nothing
Set myCmd = Nothing
Set myConn = Nothing

outArr = Arr

End Sub

Function IsFileOpen(filename As String)
Dim filenum As Integer, errnum As Integer

On Error Resume Next
filenum = FreeFile()
Open filename For Input Lock Read As #filenum
Close filenum
errnum = Err
On Error GoTo 0
Select Case errnum
Case 0
IsFileOpen = False
Case 70
IsFileOpen = True
Case Else
'Error errnum
End Select
End Function

Merci

Denys
Denys
Le #5002661
Bonjour Denis,

Effectivement, j'y ai acccès...

Merci beaucoup

Bonne fin de semaine

Denys


On 26 oct, 18:48, "MichDenis"
| Cependant, cela ne fonctionne pas si le fichier est ouvert.

| 'Must have the Microsoft Activex Data Objects 2.0 Library

Si tu as utilisé cette bibliothèque comme indiquée dans ta procéd ure,
effectivement, tu ne peux pas exécuter une requête si le classeur est
ouvert. Cependant, c'est un bug bien connu de cette bibliothèque !

Pour solutionner ton problème, si tu as accès à la même biblioth èque
du même nom version 2.8, tu n'éprouvera pas ce problème. J'ignore
à partir de quelle version, microsoft a corrigé le problème. Tu fais
un test en cochant tour à tour une version... tu verras bien.

"Denys"
Bonjour à tous,

Sur le site de Frédéric Sigonneau, j'ai pris les macros suivantes me
permettant d'aller chercher de l'info dans un fichier fermé de façon
très rapide. Cependant, cela ne fonctionne pas si le fichier est
ouvert.

Ma question est: est-il possible d'aller chercher de l'info sur une
page spécifique même si le fichier est ouvert? Voici les instructions
(modifiées pour ma cause) provenant du site de Frédéric Sigonneau:

Sub LitEmployee()
Dim Msg, Style, Title, Fichier As String
Fichier = "V:Daily Tasks" & ActiveSheet.Range("B1").Value & ".xls"
'Nom de l'employé en B1
If IsFileOpen(Fichier) Then
MsgBox "" & ActiveSheet.Range("B1").Value & "'s file is already in
use" & Chr(13) & "Please try later"
Exit Sub
'End If
Dim Fich$, Arr
Fich = "V:Daily Tasks" & ActiveSheet.Range("B1").Value & ".xls"

'récup des données à partir de l'adresse d'une plage de cellules
GetExternalData Fich, "Daily tasks", "A2:G5000", False, Arr

With ActiveSheet
.Range("A2", .Cells(UBound(Arr, 1), UBound(Arr, 2))).Value = Arr
End With

End Sub

'Must have the Microsoft Activex Data Objects 2.0 Library
'in the tools----reference---in the VBA section
Sub GetExternalData(srcFile As String, _
srcSheet As String, _
srcRange As String, _
TTL As Boolean, _
outArr As Variant)
Dim myConn As ADODB.Connection, myCmd As ADODB.Command
Dim HDR As String, myRS As ADODB.Recordset, RS_n As Integer, RS_f As
Integer
Dim Arr

Set myConn = New ADODB.Connection
If TTL = True Then HDR = "Yes" Else HDR = "No"
myConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & srcFile & ";" & _
"Extended Properties=""Excel 8.0;" & _
"HDR=" & HDR & ";IMEX=1;"""
Set myCmd = New ADODB.Command
myCmd.ActiveConnection = myConn
If srcSheet = "" _
Then myCmd.CommandText = "SELECT * from `" & srcRange & "`" _
Else myCmd.CommandText = "SELECT * from `" & srcSheet & "$" &
srcRange & "`"
Set myRS = New ADODB.Recordset
myRS.Open myCmd, , adOpenKeyset, adLockOptimistic
ReDim Arr(1 To myRS.RecordCount, 1 To myRS.Fields.Count)
myRS.MoveFirst
Do While Not myRS.EOF
For RS_n = 1 To myRS.RecordCount 'lignes
For RS_f = 0 To myRS.Fields.Count - 1 'colonnes
Arr(RS_n, RS_f + 1) = myRS.Fields(RS_f).Value
Next
myRS.MoveNext
Next
Loop
myConn.Close
Set myRS = Nothing
Set myCmd = Nothing
Set myConn = Nothing

outArr = Arr

End Sub

Function IsFileOpen(filename As String)
Dim filenum As Integer, errnum As Integer

On Error Resume Next
filenum = FreeFile()
Open filename For Input Lock Read As #filenum
Close filenum
errnum = Err
On Error GoTo 0
Select Case errnum
Case 0
IsFileOpen = False
Case 70
IsFileOpen = True
Case Else
'Error errnum
End Select
End Function

Merci

Denys


Publicité
Poster une réponse
Anonyme