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
'------------------------------------------
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
'------------------------------------------
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
'------------------------------------------
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
'------------------------------------------
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
'------------------------------------------
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
'------------------------------------------
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
isabelleBonjour à 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
'------------------------------------------
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
'------------------------------------------
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
isabelleBonjour à 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
'------------------------------------------
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
'------------------------------------------
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é" <circe@aea.gr> wrote in message
news:mn.83907d7b7ad02b55.54897@aea.gr...
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
'------------------------------------------
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
'------------------------------------------
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
'------------------------------------------
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
'------------------------------------------
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
'------------------------------------------
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
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
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