[RESOLU] Pb fonction avec 2010

Sub Import()

'Pour lire et écrire dans un classeur fermé en utilisant ADO,
'la bibliothèque
'Microsoft ActiveX Data Objects 2.x Library
'doit être cochée dans Outils\Références du VBAProject.

' 1 - Obtenir des données d'un classeur fermé


Dim Fich$, Arr

Fich = "C:\DOCUMENTS SALARIES\Chronos.xls" 'à adapter


'récup des données à partir du nom d'une plage de cellules ()
GetExternalData Fich, "", "T", False, Arr 'à adapter

With ThisWorkbook.Sheets("DIRECTION") 'à adapter
.Range("B9", .Cells(UBound(Arr, 1), UBound(Arr, 2))).Value = Arr 'à adapter
End With

End Sub

'renvoie les valeurs d'une plage de cellules contigües (srcRange)
'd'une feuille (srcSheet) d'un fichier (srcFile) fermé
'dans un tableau (outArr)
'le paramètre TTL indique si la plage a ou non une ligne d'entêtes

Sub GetExternalData(srcFile As String, _
srcSheet As String, _
srcRange As String, _
TTL As Boolean, _
outArr As Variant)
'd'après Héctor Miguel, mpep
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

Sub Test_Ouvert()

' Test to see if the file is open.
If IsFileOpen("c:\DOCUMENTS SALARIES\CHRONOS.xls") Then
' Display a message stating the file in use.
MsgBox "CHRONOS est ouvert!"
'
' Add code here to handle case where file is open by another
' user.
'
Else
' Display a message stating the file is not in use.
MsgBox "CHRONOS non ouvert!"
' Open the file in Microsoft Excel.
'Workbooks.Open "c:\DOCUMENTS SALARIES\CHRONOS.xls"
'
' Add code here to handle case where file is NOT open by another
' user.
'
End If

End Sub

' This function checks to see if a file is open or not. If the file is
' already open, it returns True. If the file is not open, it returns
' False. Otherwise, a run-time error occurs because there is
' some other problem accessing the file.

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

On Error Resume Next ' Turn error checking off.
filenum = FreeFile() ' Get a free file number.
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum ' Close the file.
errnum = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.

' Check to see which error occurred.
Select Case errnum

' No error occurred.
' File is NOT already open by another user.
Case 0
IsFileOpen = False

' Error number for "Permission Denied."
' File is already opened by another user.
Case 70
IsFileOpen = True

' Another error occurred.
Case Else
Err.Raise errnum
End Select

End Function

Cliquez pour agrandir...

Fich = "C:\DOCUMENTS SALARIES\Chronos.xls" 'à adapter

Cliquez pour agrandir...

Fich = "C:\DOCUMENTS SALARIES\Chronos.xlsm" 'à adapter

Cliquez pour agrandir...

myConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & srcFile & ";" & _
"Extended Properties=""Excel 8.0;" & _
"HDR=" & HDR & ";IMEX=1;"""

Cliquez pour agrandir...

myConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & srcFile & ";" & _
"Extended Properties=""Excel 12.0;" & _
"HDR=" & HDR & ";IMEX=1;"""

Cliquez pour agrandir...

Arr(RS_n, RS_f + 1) = myRS.Fields(RS_f).Value

Cliquez pour agrandir...