1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46
| Sub Test()
Dim Cn As Object, Rst As Object, Sql As String, Fi1 As String, Fi2 As String,client as String,safran as String
Fi2 = "C:\Users\admin\Desktop\nouveau travail\safran.xlsm"
Fi1 = "C:\Users\admin\Desktop\nouveau travail\Copie de FormIDD_DERX189100_RETOUR_SES.xlsm"
client = "Description_et_Decision_Techn"
safran = "Feuil1"
Set Cn = OpenConnetion(Fi1, False)
If TypeName(Cn) = "Nothing" Then Exit Sub
Sql = "Select Frm1.[F5] from [" & client & "$] as Frm1 inner join (Select * from [" & safran & "$] in '" & Fi2 & "' 'excel 8.0;HDR=no;IMEX=1;' )as frm2 on frm2.[F2]=frm1.[F5]"
Set Rst = OpenRecordSet(Sql, Cn)
If TypeName(Rst) = "Nothing" Then Exit Sub
Range("A135").CopyFromRecordset Rst
Rst.Close: Cn.Close
Set Rst = Nothing: Set Cn = Nothing
End Sub
Public Function OpenConnetion(FichierXls As String, AvecTitre As Boolean) As Object
On Error Resume Next
Dim HDR
If Dir(FichierXls) = "" Then MsgBox FichierXls & vbCrLf & "Pas trouvé": Exit Function
HDR = Array("No", "Yes")
Set OpenConnetion = CreateObject("ADODB.Connection")
With OpenConnetion
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & FichierXls & ";Extended Properties=""Excel 12.0 Xml;HDR=" & HDR(Abs(AvecTitre)) & ";IMEX=1;"""
.Open
If Err Then
MsgBox Err.Description
Set OpenConnetion = Nothing
End If
Err.Clear
On Error GoTo 0
End With
End Function
Public Function OpenRecordSet(Sql, Cn As Object) As Object
'Retourne un RecordeSet
On Error Resume Next
Set OpenRecordSet = CreateObject("ADODB.Recordset")
OpenRecordSet.Open Sql, Cn, 1, 3
If Err Then
MsgBox Err.Description
Set OpenRecordSet = Nothing
End If
Err.Clear
On Error GoTo 0
End Function |
Partager