Sub TestImport()
'Attention il y a trois S dans le nom de la feuille
If IsDate(Sheets("Sommaire").Range("A1")) Then
ImportDonnées ThisWorkbook.Path & "\fichieradupliquer.xls", "esssai", Year(Sheets("Sommaire").Range("A1"))
End If
End Sub
Sub ImportDonnées(NomCompletFichier As String, NomOnglet, Annee)
'
' La référence à Microsoft ActiveX Data Objects 2.n Library doit être cochée
'
Dim cnx As ADODB.Connection
Dim rsT As ADODB.Recordset
Dim SQL As String
'Il faut éviter les espaces dans les noms de champs (Source de problèmes)
'Ou alors les entrourer de []
'Il faut éviter les noms de champs qui sont des mots du langage VB (ex: Date)
'Initialisation de la chaine SQL
SQL = "SELECT LaDate ,Colonne1, Colonne3 From [" & NomOnglet & "$]" _
& " WHERE YEAR(LaDate)>=" & Annee _
& " ORDER BY LaDate;"
'Initialisation de la connexion au fichier
Set cnx = New ADODB.Connection
cnx.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & NomCompletFichier & _
";Extended Properties=""Excel 8.0;HDR=YES;"""
'Initialisation du recordset
Set rsT = New ADODB.Recordset
rsT.CursorLocation = adUseClient
'Chargement du recordset
rsT.Open SQL, cnx, adOpenStatic, adLockReadOnly
'S'il n'est pas vide copie dans la feuille
If Not rsT.EOF Then
'Pour copier tout le recordset entêtes de champs inclus
With Sheets("Sommaire")
'Lister le noms de champs à partir de A2 en ligne
ListerChamps rsT, .Range("A2"), True
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).CopyFromRecordset rsT
End With
End If
Set rsT = Nothing
cnx.Close
Set cnx = Nothing
End Sub
Sub ListerChamps(rs As ADODB.Recordset, CelluleDepart As Range, Optional bHorizontale As Boolean = True)
Dim i As Integer
If rs.State = adStateOpen Then
For i = 0 To rs.Fields.Count - 1
If bHorizontale Then
CelluleDepart.Offset(, i) = rs.Fields(i).Name
Else
CelluleDepart.Offset(, i) = rs.Fields(i).Name
End If
Next i
End If
End Sub
SQL = "SELECT Colonne1, Colonne3 From [" & NomOnglet & "$]" _
& " WHERE YEAR(LaDate)>=" & Annee _
& " ORDER BY LaDate;"
En MP à dit:Bonjour Hasco et merci de m'avoir répondu.
J'ai essayé ton code mais rien ne se passe.
J'ai mis les deux fichiers (Synthese et fichieradupliquer) dans le meme fichier mais rien.
Sinon dans le code suivant :
Code:Sub TestImport() 'Attention il y a trois S dans le nom de la feuille If IsDate(Sheets("Sommaire").Range("A1")) Then ImportDonnées ThisWorkbook.Path & "\fichieradupliquer.xls", "esssai", Year(Sheets("Sommaire").Range("A1")) End If End Sub
Je vois que tu fais appel au fichier "fichieradupliquer". et a l'onglet "esssai" alros que je souhaite qu'il ouvre chaque fichier contenu dans le dossier dans lequel il est et qu'il copie les informations suivant certains critères des onglets dont les nom sont différents de feuil1, 2, 3 et Listes. Est ce réalisable?
Je sais que je t'en demande beaucoup mais la j'ai pas le niveau nécessaire pour modifier moi meme le code, j'essai mais j'ai beaucoup de mal.
Merci
David m
Sub TestImport()
If IsDate(Sheets("Sommaire").Range("A1")) Then
ImportDonnées ThisWorkbook.Path & [COLOR=blue][COLOR=black]"\[/COLOR][B]fichieradupliquer.xls[/B][COLOR=black]"[/COLOR][B],[/B][/COLOR] [COLOR=blue][B]"esssai"[/B][/COLOR], Year(Sheets("Sommaire").Range("A1"))
End If
End Sub
Sub TestImport()
Dim NomFichier as string
Dim NomFeuille as string
NomFichier="LeFichier.xls"
NomFeuille="LaFeuille"
If IsDate(Sheets("Sommaire").Range("A1")) Then
ImportDonnées ThisWorkbook.Path & "\" & NomFichier, NomFeuille, Year(Sheets("Sommaire").Range("A1"))
End If
End Sub
'Chargement du recordset
rsT.Open SQL, cnx, adOpenStatic, adLockReadOnly