'necessite d'activer la reference Microsoft ActiveX Data Objects x.x Library
'==============================================
'compléter les variables et taper F5 ! cette routine fonctionne parfaitement!
'==============================================
Sub Essai()
Dim ChemSource$, FichSource$
Dim FeuilSource$, RangSource$
Dim FeuilDestin$, RangDestin$
'source
FichSource = "Fichier.xls" 'nom du fichier source
ChemSource = "C:\Dossier" 'nom du dossier source
FeuilSource = "Feuil1" 'nom de la feuil source
RangSource = "A10:A10" 'range source préciser ainsi! "F5:F5" "B1:C5" ...
'destination
FeuilDestin = "Feuil1" 'nom de la feuille de destination
RangDestin = "A1" 'l'adresse de destination
'appel routine
ImportUneCellOuUnRangDuClasseurFerme ChemSource$, FichSource$, FeuilSource$, RangSource$, FeuilDestin$, RangDestin$
End Sub
'****************************** NE RIEN MODIFIER CI-DESSOUS **********************************
Sub ImportUneCellOuUnRangDuClasseurFerme(ChemSource$, FichSource$, FeuilSource$, RangSource$, FeuilDestin$, RangDestin$)
'test les vars
Dim ChemFichSource$, TextSQL$
If Right(FeuilSource, 1) <> "$" Then FeuilSource = FeuilSource & "$"
If Right(ChemSource, 1) <> "\" Then ChemSource = ChemSource & "\"
ChemFichSource = ChemSource & FichSource
TextSQL = "SELECT * FROM [" & FeuilSource & RangSource & "]"
'ouverture selon version excel
Dim ADOConnect As Object, ADORecord As Object
Set ADOConnect = CreateObject("ADODB.Connection")
If Int(Val(Application.Version)) < 12 Then
ADOConnect.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data source=" & ChemFichSource & ";Extended Properties=""Excel 8.0;HDR=No;"";"
Else
ADOConnect.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ChemFichSource & ";Extended Properties=""Excel 12.0;HDR=No;"";"
End If
'load les données
Set ADORecord = CreateObject("ADODB.Recordset")
Set ADORecord = ADOConnect.Execute(TextSQL)
'recopie dans ce classeur
Sheets(FeuilDestin).Range(RangDestin).CopyFromRecordset ADORecord
'fermeture connection
ADOConnect.Close
Set ADORecord = Nothing: Set ADOConnect = Nothing
End Sub