Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel ADO me prend la tête !!

ADO me prend la tête !!

7 réponses
Avatar
Circé
Bonjour à tous !

J'ai tenté de comprendre ADO, mais vraiment je compte sur vous, parce
que ça me prend la tête !
J'avais demandé ici même il y a peu de temps comment récupérer les
données de plusieurs classeurs fermés dans la feuille en cours.

J'ai compris que ça passait par ADO qui, malgré les saines lectures
chez Frédéric, reste pour moi un truc de barbares !

J'ai récupéré la macro de MichDenis qui fonctionne mais je n'arrive pas
à l'adapter à mon cas, ce qui fait que le résultat n'est pas optimisé.

Je la copie colle ci-dessous. Si quelqu'un pouvait la modifier sachant
que dans les classeurs fermés (qui sont tous pareils), les données
commencent sur la ligne 4, que je ne veux pas récupérer les lignes
d'entêtes (même celle du premier fichier) (ligne 3), et que la première
cellule du fichier destinataire qui reçoit les données est aussi en
ligne 4 (A4).

En fait tous mes fichiers ont strictement la même structure : entêtes
en ligne 3 et données à partir de A4.
Si ça peut aider, les plages à récupérées sont nommées et s'appellent
toutes BD.

Celui ou celle qui m'aide à ma reconnaissance éternelle !! ;)))

Circé
http://faqword.free.fr


la macro de MichDenis :

'------------------------------------------
Sub Test()
'Appel d'une procédure ayant 2 paramêtres
'A ) Répertoire à scanner
'Ne pas oublier le "\" à la fin comme dans "c:\AAA\"

'B ) 'L'adresse de la première cellule du coin supérieur
'gauche où seront copiées les données recueillies
'Différente syntaxe possible pour appeler la procédure :
'Exemple de la plus longue à la plus courte :

'La plus longue : ThisWorkbook.Worksheets("Feuil2").Range("G10")
Extraire_Data_First_Excel_Sheet "c:\AAA\", _
ThisWorkbook.Worksheets("Feuil2").Range("G10")

'OU

'La plus courte : Range("G10")
Extraire_Data_First_Excel_Sheet "c:\AAA\", Range("G10")

End Sub

'------------------------------------------
Sub Extraire_Data_First_Excel_Sheet(Chemin As String, Rg As Range)

'Nécessite l 'ajoute de la bibliothèque suivante :
'"Microsoft Activex Data Object 2.x librairy"
' ET
'"Microsoft Dao 3.6 Objects librairy"

'Extrait les données de plusieurs classeurs d'un même
'répertoire en prenant pour acquis que les données ont
'la même structure. Le nom de la première feuille est
'obtenue par la fonction "FirstExcelSheetName"

Dim Conn As ADODB.Connection, Rst As New ADODB.Recordset
Dim Requete As String, NomFeuille As String
Dim file As String, C As Integer, Ok As Integer
Dim ModeCalcul As String

'Extrait le premier fichier du répertoire
file = Dir(Chemin & "\*.xls")

ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

Do While file <> ""
'Nom de la feuille où les données seront copiées
'dans le classeur où la macro est écrite :
'Détermine la première cellule où seront copiées
'les données des requêtes des classeurs
If Rg(1, 1) = "" Then
Set Rg = Rg(1, 1)
Else
Set Rg = Rg.EntireColumn.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns,
SearchDirection:=xlPrevious).Offset(1)
Ok = 1
End If

'établir la connection avec le fichier...
Set Conn = New ADODB.Connection
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Chemin & file & ";" & _
"Extended Properties=""Excel 8.0;HDR=YES;"""

'détermine le nom de la première feuille du classeur
NomFeuille = FirstExcelSheetName(Chemin & file)

'Détermine la requête à être exécuté
Requete = "SELECT * From [" & NomFeuille & "]"

'Exécution de la requête
Rst.Open Requete, Conn, adOpenForwardOnly, adLockOptimistic

'Copie le nom des champs du recordset vers Excel
'dans le cas du premier classeur seulement
If Ok <> 1 Then
Do
Rg.Offset(, C) = Rst.Fields(C).Name
C = C + 1
x = x + 1
Loop Until x = Rst.Fields.Count
'Copie le recordset vers Excel
Rg.Offset(1).CopyFromRecordset Rst
Else
'Copie le recordset vers Excel
Rg.CopyFromRecordset Rst
End If
'Passe au classeur suivant
file = Dir()
'Ferme le recordset et la connection
Rst.Close: Conn.Close
Loop
Application.Calculation = ModeCalcul
Application.EnableEvents = True
Set Rst = Nothing: Set Conn = Nothing
Set Rg = Nothing
End Sub
'------------------------------------------
Function FirstExcelSheetName(Fichier As String)
Dim XlDb As DAO.Database
Dim TbL As DAO.TableDef
Set XlDb = OpenDatabase(Fichier, False, True, "Excel 8.0;")
FirstExcelSheetName = XlDb.TableDefs(0).Name
XlDb.Close: Set XlDb = Nothing
End Function
'------------------------------------------
Signaler un problème avec ce contenu

7 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
isabelle
bonjour Circé,

je l'ai modifié comme ceci :

Sub Extraire_Data_First_Excel_Sheet(Chemin As String, Rg As Range)
Dim Conn As ADODB.Connection, Rst As New ADODB.Recordset
Dim Requete As String, NomFeuille As String
Dim file As String, C As Integer, Ok As Integer
Dim ModeCalcul As String
file = Dir(Chemin & "*.xls")

ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

Do While file <> ""
Set Rg = Range("A4:C6") '<----- modifier la plage a extraire
If Rg(1, 1) = "" Then
Set Rg = Rg(1, 1)
Else
Set Rg = Rg.Columns(1).Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Offset(1)'<----- cherche la dernière cellule vide en colonne 1
End If
Ok = 1
Set Conn = New ADODB.Connection
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Chemin & file & ";" & _
"Extended Properties=""Excel 8.0;HDR=YES;"""

NomFeuille = FirstExcelSheetName(Chemin & file)

Requete = "SELECT * From [" & NomFeuille & "]"

Rst.Open Requete, Conn, adOpenForwardOnly, adLockOptimistic

Rg.CopyFromRecordset Rst
file = Dir()
Rst.Close: Conn.Close
Loop
Application.Calculation = ModeCalcul
Application.EnableEvents = True
Set Rst = Nothing: Set Conn = Nothing
Set Rg = Nothing
End Sub


isabelle

Bonjour à tous !

J'ai tenté de comprendre ADO, mais vraiment je compte sur vous, parce
que ça me prend la tête !
J'avais demandé ici même il y a peu de temps comment récupérer les
données de plusieurs classeurs fermés dans la feuille en cours.

J'ai compris que ça passait par ADO qui, malgré les saines lectures chez
Frédéric, reste pour moi un truc de barbares !

J'ai récupéré la macro de MichDenis qui fonctionne mais je n'arrive pas
à l'adapter à mon cas, ce qui fait que le résultat n'est pas optimisé.

Je la copie colle ci-dessous. Si quelqu'un pouvait la modifier sachant
que dans les classeurs fermés (qui sont tous pareils), les données
commencent sur la ligne 4, que je ne veux pas récupérer les lignes
d'entêtes (même celle du premier fichier) (ligne 3), et que la première
cellule du fichier destinataire qui reçoit les données est aussi en
ligne 4 (A4).

En fait tous mes fichiers ont strictement la même structure : entêtes en
ligne 3 et données à partir de A4.
Si ça peut aider, les plages à récupérées sont nommées et s'appellent
toutes BD.

Celui ou celle qui m'aide à ma reconnaissance éternelle !! ;)))

Circé
http://faqword.free.fr


la macro de MichDenis :

'------------------------------------------
Sub Test()
'Appel d'une procédure ayant 2 paramêtres
'A ) Répertoire à scanner
'Ne pas oublier le "" à la fin comme dans "c:AAA"

'B ) 'L'adresse de la première cellule du coin supérieur
'gauche où seront copiées les données recueillies
'Différente syntaxe possible pour appeler la procédure :
'Exemple de la plus longue à la plus courte :

'La plus longue : ThisWorkbook.Worksheets("Feuil2").Range("G10")
Extraire_Data_First_Excel_Sheet "c:AAA", _
ThisWorkbook.Worksheets("Feuil2").Range("G10")

'OU

'La plus courte : Range("G10")
Extraire_Data_First_Excel_Sheet "c:AAA", Range("G10")

End Sub

'------------------------------------------
Sub Extraire_Data_First_Excel_Sheet(Chemin As String, Rg As Range)

'Nécessite l 'ajoute de la bibliothèque suivante :
'"Microsoft Activex Data Object 2.x librairy"
' ET
'"Microsoft Dao 3.6 Objects librairy"

'Extrait les données de plusieurs classeurs d'un même
'répertoire en prenant pour acquis que les données ont
'la même structure. Le nom de la première feuille est
'obtenue par la fonction "FirstExcelSheetName"

Dim Conn As ADODB.Connection, Rst As New ADODB.Recordset
Dim Requete As String, NomFeuille As String
Dim file As String, C As Integer, Ok As Integer
Dim ModeCalcul As String

'Extrait le premier fichier du répertoire
file = Dir(Chemin & "*.xls")

ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

Do While file <> ""
'Nom de la feuille où les données seront copiées
'dans le classeur où la macro est écrite :
'Détermine la première cellule où seront copiées
'les données des requêtes des classeurs
If Rg(1, 1) = "" Then
Set Rg = Rg(1, 1)
Else
Set Rg = Rg.EntireColumn.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Offset(1)
Ok = 1
End If

'établir la connection avec le fichier...
Set Conn = New ADODB.Connection
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Chemin & file & ";" & _
"Extended Properties=""Excel 8.0;HDR=YES;"""

'détermine le nom de la première feuille du classeur
NomFeuille = FirstExcelSheetName(Chemin & file)

'Détermine la requête à être exécuté
Requete = "SELECT * From [" & NomFeuille & "]"

'Exécution de la requête
Rst.Open Requete, Conn, adOpenForwardOnly, adLockOptimistic

'Copie le nom des champs du recordset vers Excel
'dans le cas du premier classeur seulement
If Ok <> 1 Then
Do
Rg.Offset(, C) = Rst.Fields(C).Name
C = C + 1
x = x + 1
Loop Until x = Rst.Fields.Count
'Copie le recordset vers Excel
Rg.Offset(1).CopyFromRecordset Rst
Else
'Copie le recordset vers Excel
Rg.CopyFromRecordset Rst
End If
'Passe au classeur suivant
file = Dir()
'Ferme le recordset et la connection
Rst.Close: Conn.Close
Loop
Application.Calculation = ModeCalcul
Application.EnableEvents = True
Set Rst = Nothing: Set Conn = Nothing
Set Rg = Nothing
End Sub
'------------------------------------------
Function FirstExcelSheetName(Fichier As String)
Dim XlDb As DAO.Database
Dim TbL As DAO.TableDef
Set XlDb = OpenDatabase(Fichier, False, True, "Excel 8.0;")
FirstExcelSheetName = XlDb.TableDefs(0).Name
XlDb.Close: Set XlDb = Nothing
End Function
'------------------------------------------




Avatar
Mishell
Bonjour.

Sub extraction_BD_ClasseurFerme()
Dim Source As ADODB.Connection
Dim Rst As ADODB.Recordset
Dim ADOCommand As ADODB.Command
Dim Fichier As String, Feuille As String

'Définit le répertoire
Chemin = "C:aaa"

Fichier = Dir(Chemin & "*.xls")

Do While Fichier <> ""

DerniereLigne& = Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row

Set Rg = Cells(DerniereLigne&, 1).Offset(1)

Rg.Select

Set Source = New ADODB.Connection
Source.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Fichier & ";Extended Properties=""Excel
8.0;HDR=No;"";"

Set ADOCommand = New ADODB.Command
With ADOCommand
.ActiveConnection = Source
.CommandText = "SELECT * FROM BD"
End With

Set Rst = New ADODB.Recordset
Rst.Open ADOCommand, , adOpenKeyset, adLockOptimistic

Set Rst = Source.Execute("bd")

Rg.CopyFromRecordset Rst

Rst.Close
Source.Close
Set Source = Nothing
Set Rst = Nothing
Set ADOCommand = Nothing

Fichier = Dir()
Loop
End Sub


Mishell



"Circé" wrote in message
news:
Bonjour à tous !

J'ai tenté de comprendre ADO, mais vraiment je compte sur vous, parce que
ça me prend la tête !
J'avais demandé ici même il y a peu de temps comment récupérer les données
de plusieurs classeurs fermés dans la feuille en cours.

J'ai compris que ça passait par ADO qui, malgré les saines lectures chez
Frédéric, reste pour moi un truc de barbares !

J'ai récupéré la macro de MichDenis qui fonctionne mais je n'arrive pas à
l'adapter à mon cas, ce qui fait que le résultat n'est pas optimisé.

Je la copie colle ci-dessous. Si quelqu'un pouvait la modifier sachant que
dans les classeurs fermés (qui sont tous pareils), les données commencent
sur la ligne 4, que je ne veux pas récupérer les lignes d'entêtes (même
celle du premier fichier) (ligne 3), et que la première cellule du fichier
destinataire qui reçoit les données est aussi en ligne 4 (A4).

En fait tous mes fichiers ont strictement la même structure : entêtes en
ligne 3 et données à partir de A4.
Si ça peut aider, les plages à récupérées sont nommées et s'appellent
toutes BD.

Celui ou celle qui m'aide à ma reconnaissance éternelle !! ;)))

Circé
http://faqword.free.fr


la macro de MichDenis :

'------------------------------------------
Sub Test()
'Appel d'une procédure ayant 2 paramêtres
'A ) Répertoire à scanner
'Ne pas oublier le "" à la fin comme dans "c:AAA"

'B ) 'L'adresse de la première cellule du coin supérieur
'gauche où seront copiées les données recueillies
'Différente syntaxe possible pour appeler la procédure :
'Exemple de la plus longue à la plus courte :

'La plus longue : ThisWorkbook.Worksheets("Feuil2").Range("G10")
Extraire_Data_First_Excel_Sheet "c:AAA", _
ThisWorkbook.Worksheets("Feuil2").Range("G10")

'OU

'La plus courte : Range("G10")
Extraire_Data_First_Excel_Sheet "c:AAA", Range("G10")

End Sub

'------------------------------------------
Sub Extraire_Data_First_Excel_Sheet(Chemin As String, Rg As Range)

'Nécessite l 'ajoute de la bibliothèque suivante :
'"Microsoft Activex Data Object 2.x librairy"
' ET
'"Microsoft Dao 3.6 Objects librairy"

'Extrait les données de plusieurs classeurs d'un même
'répertoire en prenant pour acquis que les données ont
'la même structure. Le nom de la première feuille est
'obtenue par la fonction "FirstExcelSheetName"

Dim Conn As ADODB.Connection, Rst As New ADODB.Recordset
Dim Requete As String, NomFeuille As String
Dim file As String, C As Integer, Ok As Integer
Dim ModeCalcul As String

'Extrait le premier fichier du répertoire
file = Dir(Chemin & "*.xls")

ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

Do While file <> ""
'Nom de la feuille où les données seront copiées
'dans le classeur où la macro est écrite :
'Détermine la première cellule où seront copiées
'les données des requêtes des classeurs
If Rg(1, 1) = "" Then
Set Rg = Rg(1, 1)
Else
Set Rg = Rg.EntireColumn.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns,
SearchDirection:=xlPrevious).Offset(1)
Ok = 1
End If

'établir la connection avec le fichier...
Set Conn = New ADODB.Connection
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Chemin & file & ";" & _
"Extended Properties=""Excel 8.0;HDR=YES;"""

'détermine le nom de la première feuille du classeur
NomFeuille = FirstExcelSheetName(Chemin & file)

'Détermine la requête à être exécuté
Requete = "SELECT * From [" & NomFeuille & "]"

'Exécution de la requête
Rst.Open Requete, Conn, adOpenForwardOnly, adLockOptimistic

'Copie le nom des champs du recordset vers Excel
'dans le cas du premier classeur seulement
If Ok <> 1 Then
Do
Rg.Offset(, C) = Rst.Fields(C).Name
C = C + 1
x = x + 1
Loop Until x = Rst.Fields.Count
'Copie le recordset vers Excel
Rg.Offset(1).CopyFromRecordset Rst
Else
'Copie le recordset vers Excel
Rg.CopyFromRecordset Rst
End If
'Passe au classeur suivant
file = Dir()
'Ferme le recordset et la connection
Rst.Close: Conn.Close
Loop
Application.Calculation = ModeCalcul
Application.EnableEvents = True
Set Rst = Nothing: Set Conn = Nothing
Set Rg = Nothing
End Sub
'------------------------------------------
Function FirstExcelSheetName(Fichier As String)
Dim XlDb As DAO.Database
Dim TbL As DAO.TableDef
Set XlDb = OpenDatabase(Fichier, False, True, "Excel 8.0;")
FirstExcelSheetName = XlDb.TableDefs(0).Name
XlDb.Close: Set XlDb = Nothing
End Function
'------------------------------------------




Avatar
Circé
Merci isabelle,

Je me sens moins seule, mais... ça ne marche pas mieux... :(

Tout d'abord, je sais où commencent les données (en A4), je connais le
nombre de colonnes, mais je ne connais pas le nombre de lignes qui est
variable. Donc mettre le nom de la plage en dur, ça ne va pas.
J'ai tenté de mettre le nom de la plage nommé ("BD"), mais ça me
renvoie une erreur.

Et même en testant sur des fichiers de même longueur, ça me laisse la
ligne 5 vide, et sur la ligne 6 je récupère les entêtes... Les données
commencent sur la ligne 7. Et puis maintenant je n'ai plus toutes les
données !!!

Bref, je ne comprends rien du tout, et ça continue de me prendre la
tête ! :(:(:(:(

Circé
http://faqword.free.fr


isabelle a utilisé son clavier pour écrire :
bonjour Circé,

je l'ai modifié comme ceci :

Sub Extraire_Data_First_Excel_Sheet(Chemin As String, Rg As Range)
Dim Conn As ADODB.Connection, Rst As New ADODB.Recordset
Dim Requete As String, NomFeuille As String
Dim file As String, C As Integer, Ok As Integer
Dim ModeCalcul As String
file = Dir(Chemin & "*.xls")

ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

Do While file <> ""
Set Rg = Range("A4:C6") '<----- modifier la plage a extraire
If Rg(1, 1) = "" Then
Set Rg = Rg(1, 1)
Else
Set Rg = Rg.Columns(1).Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns,
SearchDirection:=xlPrevious).Offset(1)'<----- cherche la dernière cellule
vide en colonne 1
End If
Ok = 1
Set Conn = New ADODB.Connection
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Chemin & file & ";" & _
"Extended Properties=""Excel 8.0;HDR=YES;"""

NomFeuille = FirstExcelSheetName(Chemin & file)

Requete = "SELECT * From [" & NomFeuille & "]"

Rst.Open Requete, Conn, adOpenForwardOnly, adLockOptimistic

Rg.CopyFromRecordset Rst
file = Dir()
Rst.Close: Conn.Close
Loop
Application.Calculation = ModeCalcul
Application.EnableEvents = True
Set Rst = Nothing: Set Conn = Nothing
Set Rg = Nothing
End Sub


isabelle

Bonjour à tous !

J'ai tenté de comprendre ADO, mais vraiment je compte sur vous, parce que
ça me prend la tête !
J'avais demandé ici même il y a peu de temps comment récupérer les données
de plusieurs classeurs fermés dans la feuille en cours.

J'ai compris que ça passait par ADO qui, malgré les saines lectures chez
Frédéric, reste pour moi un truc de barbares !

J'ai récupéré la macro de MichDenis qui fonctionne mais je n'arrive pas à
l'adapter à mon cas, ce qui fait que le résultat n'est pas optimisé.

Je la copie colle ci-dessous. Si quelqu'un pouvait la modifier sachant que
dans les classeurs fermés (qui sont tous pareils), les données commencent
sur la ligne 4, que je ne veux pas récupérer les lignes d'entêtes (même
celle du premier fichier) (ligne 3), et que la première cellule du fichier
destinataire qui reçoit les données est aussi en ligne 4 (A4).

En fait tous mes fichiers ont strictement la même structure : entêtes en
ligne 3 et données à partir de A4.
Si ça peut aider, les plages à récupérées sont nommées et s'appellent
toutes BD.

Celui ou celle qui m'aide à ma reconnaissance éternelle !! ;)))

Circé
http://faqword.free.fr


la macro de MichDenis :

'------------------------------------------
Sub Test()
'Appel d'une procédure ayant 2 paramêtres
'A ) Répertoire à scanner
'Ne pas oublier le "" à la fin comme dans "c:AAA"

'B ) 'L'adresse de la première cellule du coin supérieur
'gauche où seront copiées les données recueillies
'Différente syntaxe possible pour appeler la procédure :
'Exemple de la plus longue à la plus courte :

'La plus longue : ThisWorkbook.Worksheets("Feuil2").Range("G10")
Extraire_Data_First_Excel_Sheet "c:AAA", _
ThisWorkbook.Worksheets("Feuil2").Range("G10")

'OU

'La plus courte : Range("G10")
Extraire_Data_First_Excel_Sheet "c:AAA", Range("G10")

End Sub

'------------------------------------------
Sub Extraire_Data_First_Excel_Sheet(Chemin As String, Rg As Range)

'Nécessite l 'ajoute de la bibliothèque suivante :
'"Microsoft Activex Data Object 2.x librairy"
' ET
'"Microsoft Dao 3.6 Objects librairy"

'Extrait les données de plusieurs classeurs d'un même
'répertoire en prenant pour acquis que les données ont
'la même structure. Le nom de la première feuille est
'obtenue par la fonction "FirstExcelSheetName"

Dim Conn As ADODB.Connection, Rst As New ADODB.Recordset
Dim Requete As String, NomFeuille As String
Dim file As String, C As Integer, Ok As Integer
Dim ModeCalcul As String

'Extrait le premier fichier du répertoire
file = Dir(Chemin & "*.xls")

ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

Do While file <> ""
'Nom de la feuille où les données seront copiées
'dans le classeur où la macro est écrite :
'Détermine la première cellule où seront copiées
'les données des requêtes des classeurs
If Rg(1, 1) = "" Then
Set Rg = Rg(1, 1)
Else
Set Rg = Rg.EntireColumn.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Offset(1)
Ok = 1
End If

'établir la connection avec le fichier...
Set Conn = New ADODB.Connection
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Chemin & file & ";" & _
"Extended Properties=""Excel 8.0;HDR=YES;"""

'détermine le nom de la première feuille du classeur
NomFeuille = FirstExcelSheetName(Chemin & file)

'Détermine la requête à être exécuté
Requete = "SELECT * From [" & NomFeuille & "]"

'Exécution de la requête
Rst.Open Requete, Conn, adOpenForwardOnly, adLockOptimistic

'Copie le nom des champs du recordset vers Excel
'dans le cas du premier classeur seulement
If Ok <> 1 Then
Do
Rg.Offset(, C) = Rst.Fields(C).Name
C = C + 1
x = x + 1
Loop Until x = Rst.Fields.Count
'Copie le recordset vers Excel
Rg.Offset(1).CopyFromRecordset Rst
Else
'Copie le recordset vers Excel
Rg.CopyFromRecordset Rst
End If
'Passe au classeur suivant
file = Dir()
'Ferme le recordset et la connection
Rst.Close: Conn.Close
Loop
Application.Calculation = ModeCalcul
Application.EnableEvents = True
Set Rst = Nothing: Set Conn = Nothing
Set Rg = Nothing
End Sub
'------------------------------------------
Function FirstExcelSheetName(Fichier As String)
Dim XlDb As DAO.Database
Dim TbL As DAO.TableDef
Set XlDb = OpenDatabase(Fichier, False, True, "Excel 8.0;")
FirstExcelSheetName = XlDb.TableDefs(0).Name
XlDb.Close: Set XlDb = Nothing
End Function
'------------------------------------------






Avatar
Circé
Bonjour Mishell,

Merci de te pencher sur le problème. J'ai testé la macro, et j'ai une
erreur sur la ligne :

Rst.Open ADOCommand, , adOpenKeyset, adLockOptimistic


"Le moteur de base de données Ms Jet n'a pas pu trouver l'objet "BD".
Assurez que l'objet existe, que vous avez correctement saisi son nom et
son chemin d'accès".

S'il s'agit de mes plages nommées, elles existent bien.
Le chemin est correct...

Que faire ?...

Circé
http://faqword.free.fr

Mishell a émis l'idée suivante :
Bonjour.

Sub extraction_BD_ClasseurFerme()
Dim Source As ADODB.Connection
Dim Rst As ADODB.Recordset
Dim ADOCommand As ADODB.Command
Dim Fichier As String, Feuille As String

'Définit le répertoire
Chemin = "C:aaa"

Fichier = Dir(Chemin & "*.xls")

Do While Fichier <> ""

DerniereLigne& = Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row

Set Rg = Cells(DerniereLigne&, 1).Offset(1)

Rg.Select

Set Source = New ADODB.Connection
Source.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Fichier & ";Extended Properties=""Excel
8.0;HDR=No;"";"

Set ADOCommand = New ADODB.Command
With ADOCommand
.ActiveConnection = Source
.CommandText = "SELECT * FROM BD"
End With

Set Rst = New ADODB.Recordset
Rst.Open ADOCommand, , adOpenKeyset, adLockOptimistic

Set Rst = Source.Execute("bd")

Rg.CopyFromRecordset Rst

Rst.Close
Source.Close
Set Source = Nothing
Set Rst = Nothing
Set ADOCommand = Nothing

Fichier = Dir()
Loop
End Sub


Mishell



"Circé" wrote in message
news:
Bonjour à tous !

J'ai tenté de comprendre ADO, mais vraiment je compte sur vous, parce que
ça me prend la tête !
J'avais demandé ici même il y a peu de temps comment récupérer les données
de plusieurs classeurs fermés dans la feuille en cours.

J'ai compris que ça passait par ADO qui, malgré les saines lectures chez
Frédéric, reste pour moi un truc de barbares !

J'ai récupéré la macro de MichDenis qui fonctionne mais je n'arrive pas à
l'adapter à mon cas, ce qui fait que le résultat n'est pas optimisé.

Je la copie colle ci-dessous. Si quelqu'un pouvait la modifier sachant que
dans les classeurs fermés (qui sont tous pareils), les données commencent
sur la ligne 4, que je ne veux pas récupérer les lignes d'entêtes (même
celle du premier fichier) (ligne 3), et que la première cellule du fichier
destinataire qui reçoit les données est aussi en ligne 4 (A4).

En fait tous mes fichiers ont strictement la même structure : entêtes en
ligne 3 et données à partir de A4.
Si ça peut aider, les plages à récupérées sont nommées et s'appellent
toutes BD.

Celui ou celle qui m'aide à ma reconnaissance éternelle !! ;)))

Circé
http://faqword.free.fr


la macro de MichDenis :

'------------------------------------------
Sub Test()
'Appel d'une procédure ayant 2 paramêtres
'A ) Répertoire à scanner
'Ne pas oublier le "" à la fin comme dans "c:AAA"

'B ) 'L'adresse de la première cellule du coin supérieur
'gauche où seront copiées les données recueillies
'Différente syntaxe possible pour appeler la procédure :
'Exemple de la plus longue à la plus courte :

'La plus longue : ThisWorkbook.Worksheets("Feuil2").Range("G10")
Extraire_Data_First_Excel_Sheet "c:AAA", _
ThisWorkbook.Worksheets("Feuil2").Range("G10")

'OU

'La plus courte : Range("G10")
Extraire_Data_First_Excel_Sheet "c:AAA", Range("G10")

End Sub

'------------------------------------------
Sub Extraire_Data_First_Excel_Sheet(Chemin As String, Rg As Range)

'Nécessite l 'ajoute de la bibliothèque suivante :
'"Microsoft Activex Data Object 2.x librairy"
' ET
'"Microsoft Dao 3.6 Objects librairy"

'Extrait les données de plusieurs classeurs d'un même
'répertoire en prenant pour acquis que les données ont
'la même structure. Le nom de la première feuille est
'obtenue par la fonction "FirstExcelSheetName"

Dim Conn As ADODB.Connection, Rst As New ADODB.Recordset
Dim Requete As String, NomFeuille As String
Dim file As String, C As Integer, Ok As Integer
Dim ModeCalcul As String

'Extrait le premier fichier du répertoire
file = Dir(Chemin & "*.xls")

ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

Do While file <> ""
'Nom de la feuille où les données seront copiées
'dans le classeur où la macro est écrite :
'Détermine la première cellule où seront copiées
'les données des requêtes des classeurs
If Rg(1, 1) = "" Then
Set Rg = Rg(1, 1)
Else
Set Rg = Rg.EntireColumn.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Offset(1)
Ok = 1
End If

'établir la connection avec le fichier...
Set Conn = New ADODB.Connection
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Chemin & file & ";" & _
"Extended Properties=""Excel 8.0;HDR=YES;"""

'détermine le nom de la première feuille du classeur
NomFeuille = FirstExcelSheetName(Chemin & file)

'Détermine la requête à être exécuté
Requete = "SELECT * From [" & NomFeuille & "]"

'Exécution de la requête
Rst.Open Requete, Conn, adOpenForwardOnly, adLockOptimistic

'Copie le nom des champs du recordset vers Excel
'dans le cas du premier classeur seulement
If Ok <> 1 Then
Do
Rg.Offset(, C) = Rst.Fields(C).Name
C = C + 1
x = x + 1
Loop Until x = Rst.Fields.Count
'Copie le recordset vers Excel
Rg.Offset(1).CopyFromRecordset Rst
Else
'Copie le recordset vers Excel
Rg.CopyFromRecordset Rst
End If
'Passe au classeur suivant
file = Dir()
'Ferme le recordset et la connection
Rst.Close: Conn.Close
Loop
Application.Calculation = ModeCalcul
Application.EnableEvents = True
Set Rst = Nothing: Set Conn = Nothing
Set Rg = Nothing
End Sub
'------------------------------------------
Function FirstExcelSheetName(Fichier As String)
Dim XlDb As DAO.Database
Dim TbL As DAO.TableDef
Set XlDb = OpenDatabase(Fichier, False, True, "Excel 8.0;")
FirstExcelSheetName = XlDb.TableDefs(0).Name
XlDb.Close: Set XlDb = Nothing
End Function
'------------------------------------------






Avatar
MichDenis
Les arguments de la procédure Extraire_Data_First_Excel_Sheet
sont les suivants :
A ) le chemin du répertoire où sont tes fichiers
B ) Où veux-tu copier le résultats des requêtes
(ça peut être dans le même classeur où est le code ou dans
dans un autre classeur -> à adapter la syntaxe en conséquence)
C ) La plage de données des tableaux à récupérer
Elle débute en A4 pour se terminer en colonne x et dernière ligne de la feuille
Excmple : Range("A4:B65536")
OU
Range("A4:H65536")

Et si tu n'est pas certaine du nombre de colonnes, tu peux en mettre plus que moins
Range("A4:AV65536")

Quand je dois apporter des corrections à une de mes procédures parce
que la demanderesse à modifier la formulation de la problématique...
le service n'est plus gratuit .... ;-)

'------------------------------------------
Sub Test()

'Autre classeur ouvert que celui de la procédure
Extraire_Data_First_Excel_Sheet "c:AAA", _
ThisWorkbook.Worksheets("Feuil2").Range("G10"), _
Range("A4:B65536")

End Sub
'------------------------------------------

Sub Extraire_Data_First_Excel_Sheet(Chemin As String, _
Rg As Range, Plg_extraire As Range)

'Nécessite l 'ajoute de la bibliothèque suivante :
'"Microsoft Activex Data Object 2.x librairy"
' ET
'"Microsoft Dao 3.6 Objects librairy"

'Extrait les données de plusieurs classeurs d'un même
'répertoire en prenant pour acquis que les données ont
'la même structure. Le nom de la première feuille est
'obtenue par la fonction "FirstExcelSheetName"

Dim Conn As ADODB.Connection, Rst As New ADODB.Recordset
Dim Requete As String, NomFeuille As String
Dim file As String, C As Integer, Ok As Integer
Dim ModeCalcul As String

'Extrait le premier fichier du répertoire
file = Dir(Chemin & "*.xls")

ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

Do While file <> ""
'Exclure le classeur où sont copiées les données
'pour ne pas dédoubler les data...

If Chemin & Rg.Parent.Parent.Name <> Chemin & file Then
'Identifier la cellule supérieur de gauche
'où seront copiées les données
If Rg(1, 1) = "" Then
Set Rg = Rg(1, 1)
Else
Set Rg = Rg.EntireColumn.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Offset(1)
Ok = 1
End If

'établir la connection avec le fichier...
Set Conn = New ADODB.Connection
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Chemin & file & ";" & _
"Extended Properties=""Excel 8.0;HDR=NO;"""

'détermine le nom de la première feuille du classeur
NomFeuille = FirstExcelSheetName(Chemin & file)

'Détermine la requête à être exécuté
Requete = "SELECT * From [" & NomFeuille & Plg_extraire.Address(0, 0) & "]"

'Exécution de la requête
Rst.Open Requete, Conn, adOpenForwardOnly, adLockOptimistic
Rg.CopyFromRecordset Rst

'Ferme le recordset et la connection
Rst.Close: Conn.Close
'Passe au classeur suivant
file = Dir()
Else
'Passe au classeur suivant si le fichier
'où sont copiées les données est le même
'que celui qui est traité dans cette sub.
file = Dir()
End If
Loop
Application.EnableEvents = True
Application.Calculation = ModeCalcul
Set Rst = Nothing: Set Conn = Nothing
Set Rg = Nothing
End Sub
'------------------------------------------
Function FirstExcelSheetName(Fichier As String)
'"Microsoft Dao 3.6 Objects librairy"
Dim XlDb As DAO.Database
Dim TbL As DAO.TableDef
Set XlDb = OpenDatabase(Fichier, False, True, "Excel 8.0;")
FirstExcelSheetName = XlDb.TableDefs(0).Name
XlDb.Close: Set XlDb = Nothing
End Function
'------------------------------------------
Avatar
Circé
Bonjour MichDenis !

OUF ! OUF !

ça marche !!!....
J'ai pas vraiment compris comment ça marche... mais ce n'est plus
l'heure pour moi de me poser des questions ! ;)))

Quand je dois apporter des corrections à une de mes procédures parce
que la demanderesse à modifier la formulation de la problématique...
le service n'est plus gratuit .... ;-)


Eh bien la demandeuse, demandante et demanderesse... tout ça à la
fois... pour parodier qui vous savez, te donne déjà sa reconnaissance à
vie comme promis !!!! Ça ne suffit pas ?.... :D

Circé
http://faqword.free.fr



'------------------------------------------
Sub Test()

'Autre classeur ouvert que celui de la procédure
Extraire_Data_First_Excel_Sheet "c:AAA", _
ThisWorkbook.Worksheets("Feuil2").Range("G10"), _
Range("A4:B65536")

End Sub
'------------------------------------------

Sub Extraire_Data_First_Excel_Sheet(Chemin As String, _
Rg As Range, Plg_extraire As Range)

'Nécessite l 'ajoute de la bibliothèque suivante :
'"Microsoft Activex Data Object 2.x librairy"
' ET
'"Microsoft Dao 3.6 Objects librairy"

'Extrait les données de plusieurs classeurs d'un même
'répertoire en prenant pour acquis que les données ont
'la même structure. Le nom de la première feuille est
'obtenue par la fonction "FirstExcelSheetName"

Dim Conn As ADODB.Connection, Rst As New ADODB.Recordset
Dim Requete As String, NomFeuille As String
Dim file As String, C As Integer, Ok As Integer
Dim ModeCalcul As String

'Extrait le premier fichier du répertoire
file = Dir(Chemin & "*.xls")

ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

Do While file <> ""
'Exclure le classeur où sont copiées les données
'pour ne pas dédoubler les data...

If Chemin & Rg.Parent.Parent.Name <> Chemin & file Then
'Identifier la cellule supérieur de gauche
'où seront copiées les données
If Rg(1, 1) = "" Then
Set Rg = Rg(1, 1)
Else
Set Rg = Rg.EntireColumn.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns,
SearchDirection:=xlPrevious).Offset(1) Ok = 1
End If

'établir la connection avec le fichier...
Set Conn = New ADODB.Connection
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Chemin & file & ";" & _
"Extended Properties=""Excel 8.0;HDR=NO;"""

'détermine le nom de la première feuille du classeur
NomFeuille = FirstExcelSheetName(Chemin & file)

'Détermine la requête à être exécuté
Requete = "SELECT * From [" & NomFeuille & Plg_extraire.Address(0, 0)
& "]"

'Exécution de la requête
Rst.Open Requete, Conn, adOpenForwardOnly, adLockOptimistic
Rg.CopyFromRecordset Rst

'Ferme le recordset et la connection
Rst.Close: Conn.Close
'Passe au classeur suivant
file = Dir()
Else
'Passe au classeur suivant si le fichier
'où sont copiées les données est le même
'que celui qui est traité dans cette sub.
file = Dir()
End If
Loop
Application.EnableEvents = True
Application.Calculation = ModeCalcul
Set Rst = Nothing: Set Conn = Nothing
Set Rg = Nothing
End Sub
'------------------------------------------
Function FirstExcelSheetName(Fichier As String)
'"Microsoft Dao 3.6 Objects librairy"
Dim XlDb As DAO.Database
Dim TbL As DAO.TableDef
Set XlDb = OpenDatabase(Fichier, False, True, "Excel 8.0;")
FirstExcelSheetName = XlDb.TableDefs(0).Name
XlDb.Close: Set XlDb = Nothing
End Function
'------------------------------------------


Avatar
Mgr Banni
tout dépend de la longueur de la vie...
dans un cas semblable, nous, les auvergnats, sommes capables de faire très
court
sachant qu'ensuite, nous sommes pris en main par
Mgr T.Banni

"Circé" a écrit dans le message de news:

Eh bien la demandeuse, demandante et demanderesse... tout ça à la fois...
pour parodier qui vous savez, te donne déjà sa reconnaissance à vie comme
promis !!!! Ça ne suffit pas ?.... :D

Circé
http://faqword.free.fr