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 47 48 49 50 51 52 53
| 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) 'ici j'ouvre une connexion adodb via une fonction
If TypeName(Cn) = "Nothing" Then Exit Sub 'si la connexion ne se fait pas je quitte la sub
'la je formule ma requête frm1 et ma sous requête frm2
'il est possible d'imbriquer dz requête frm2 fait un jointure externe au deuxième fichier Excel
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) 'la j'ouvre mon recordset via une fonction
If TypeName(Rst) = "Nothing" Then Exit Sub 'si erreur je quitte la 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
'ouvre la connexion au fichier Excel
'FichierXls non et chemin complet du fichier
'AvecTitre précise si la première ligne de l'onglet est les entête de colonnes ou pas
'rzutourne la connexion
On Error Resume Next
Dim HDR
If Dir(FichierXls) = "" Then MsgBox FichierXls & vbCrLf & "Pas trouvé": Exit Function ' versifie si le fichier existe
HDR = Array("No", "Yes")
Set OpenConnetion = CreateObject("ADODB.Connection") Instancie un objet adosb c'est mieux que d'utiliser le références
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 recordset
'Retourne un RecordeSet
On Error Resume Next
Set OpenRecordSet = CreateObject("ADODB.Recordset")
OpenRecordSet.Open Sql, Cn, 1, 3 'ouvre un recordset sur la requête SQL pour la connexion en lecteur écriture et ajou dynamique
If Err Then
MsgBox Err.Description
Set OpenRecordSet = Nothing
End If
Err.Clear
On Error GoTo 0
End Function |
Partager