Bonjour Alain,
Ceci récupère TOUTES les données de la PREMIÈRE feuille
de chacun des classeurs fermés contenu dans un répertoire et les
copient où tu désires. Si la feuille de chaque classeur a le
même nom, il est possible de simplifier un peu la procédure.
Selon ton niveau en Excel, cela peut être plus difficile d'accès.
Il est possible de faire une simple boucle et d'ouvrir les fichiers
à tour de rôle pour en extraire les données. Est-ce que chaque
feuille de chaque classeur a le même nom ?
Toutes les feuilles de données sont réputées avoir
une ligne d'étiquette définissant les champs de la table.
Ne pas oublier de déclarer les bibliothèques mentionnées
dans la procédure : "Extraire_Data_First_Excel_Sheet"
Microsoft Activex Data Object 2.x librairy"
' ET
Microsoft Dao 3.6 Objects librairy"
'------------------------------------------
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 d'indiquer la cellule
'à partir de laquelle seront copiés les résultats.
'Choisis celle qui te convient.
'----------1----------
'Même classeur que la procédure, dans la Feuil2
'Extraire_Data_First_Excel_Sheet "c:AAA", _
ThisWorkbook.Worksheets("Feuil2").Range("G10")
'-----------2----------
'Autre classeur ouvert que celui de la procédure
Extraire_Data_First_Excel_Sheet "c:AAA", _
Workbooks("Classeur2").Worksheets("Feuil2").Range("G10")
''-----------3----------
'Dans la feuille active du classeur actif au
'moment de lancer la procédure
' 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 <> ""
'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=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
'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
'------------------------------------------
"alain" a écrit dans le message de groupe de discussion
:
Bonjour, j'aimerais effectuer une fusion de plusieurs fichier identique en
nombre de collonne (avec les mêmes champs identiques) au début de lafeuilleil
y a des calculs automatique avec des macros d'insérer dans certaine cellule.
Le but de la fusion est de trier par nom exemple une collonne pour ensuite
copier toutes les données de ce nom et faire une nouvelle feuille de calcul
pour ainsi traiter seulement ses données
Merci de votre aide
Bonjour Alain,
Ceci récupère TOUTES les données de la PREMIÈRE feuille
de chacun des classeurs fermés contenu dans un répertoire et les
copient où tu désires. Si la feuille de chaque classeur a le
même nom, il est possible de simplifier un peu la procédure.
Selon ton niveau en Excel, cela peut être plus difficile d'accès.
Il est possible de faire une simple boucle et d'ouvrir les fichiers
à tour de rôle pour en extraire les données. Est-ce que chaque
feuille de chaque classeur a le même nom ?
Toutes les feuilles de données sont réputées avoir
une ligne d'étiquette définissant les champs de la table.
Ne pas oublier de déclarer les bibliothèques mentionnées
dans la procédure : "Extraire_Data_First_Excel_Sheet"
Microsoft Activex Data Object 2.x librairy"
' ET
Microsoft Dao 3.6 Objects librairy"
'------------------------------------------
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 d'indiquer la cellule
'à partir de laquelle seront copiés les résultats.
'Choisis celle qui te convient.
'----------1----------
'Même classeur que la procédure, dans la Feuil2
'Extraire_Data_First_Excel_Sheet "c:AAA", _
ThisWorkbook.Worksheets("Feuil2").Range("G10")
'-----------2----------
'Autre classeur ouvert que celui de la procédure
Extraire_Data_First_Excel_Sheet "c:AAA", _
Workbooks("Classeur2").Worksheets("Feuil2").Range("G10")
''-----------3----------
'Dans la feuille active du classeur actif au
'moment de lancer la procédure
' 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 <> ""
'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=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
'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
'------------------------------------------
"alain" <alain@discussions.microsoft.com> a écrit dans le message de groupe de discussion
: AB68D3E9-FB0C-4E95-9D81-64DEBE65DB04@microsoft.com...
Bonjour, j'aimerais effectuer une fusion de plusieurs fichier identique en
nombre de collonne (avec les mêmes champs identiques) au début de lafeuilleil
y a des calculs automatique avec des macros d'insérer dans certaine cellule.
Le but de la fusion est de trier par nom exemple une collonne pour ensuite
copier toutes les données de ce nom et faire une nouvelle feuille de calcul
pour ainsi traiter seulement ses données
Merci de votre aide
Bonjour Alain,
Ceci récupère TOUTES les données de la PREMIÈRE feuille
de chacun des classeurs fermés contenu dans un répertoire et les
copient où tu désires. Si la feuille de chaque classeur a le
même nom, il est possible de simplifier un peu la procédure.
Selon ton niveau en Excel, cela peut être plus difficile d'accès.
Il est possible de faire une simple boucle et d'ouvrir les fichiers
à tour de rôle pour en extraire les données. Est-ce que chaque
feuille de chaque classeur a le même nom ?
Toutes les feuilles de données sont réputées avoir
une ligne d'étiquette définissant les champs de la table.
Ne pas oublier de déclarer les bibliothèques mentionnées
dans la procédure : "Extraire_Data_First_Excel_Sheet"
Microsoft Activex Data Object 2.x librairy"
' ET
Microsoft Dao 3.6 Objects librairy"
'------------------------------------------
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 d'indiquer la cellule
'à partir de laquelle seront copiés les résultats.
'Choisis celle qui te convient.
'----------1----------
'Même classeur que la procédure, dans la Feuil2
'Extraire_Data_First_Excel_Sheet "c:AAA", _
ThisWorkbook.Worksheets("Feuil2").Range("G10")
'-----------2----------
'Autre classeur ouvert que celui de la procédure
Extraire_Data_First_Excel_Sheet "c:AAA", _
Workbooks("Classeur2").Worksheets("Feuil2").Range("G10")
''-----------3----------
'Dans la feuille active du classeur actif au
'moment de lancer la procédure
' 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 <> ""
'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=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
'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
'------------------------------------------
"alain" a écrit dans le message de groupe de discussion
:
Bonjour, j'aimerais effectuer une fusion de plusieurs fichier identique en
nombre de collonne (avec les mêmes champs identiques) au début de lafeuilleil
y a des calculs automatique avec des macros d'insérer dans certaine cellule.
Le but de la fusion est de trier par nom exemple une collonne pour ensuite
copier toutes les données de ce nom et faire une nouvelle feuille de calcul
pour ainsi traiter seulement ses données
Merci de votre aide
Je ne faisais pas référence au nom de fichier, mais au nom
de la feuille de chaque classeur dans laquelle sont tes données.
a ) Pour te simplifier la tâche, tu ouvres la fenêtre de l'éditeur de code
par le raccourci clavier Alt + F11
b ) Tu insères un module standard à partir du menu "Insertion" de la barre des menus.
c ) Tu y copies les procédures suivantes.
c ) Tu ajoutes les deux bibliothèques : Barre des menus / outils / références /
et tu les coches parmi la liste :
Microsoft Activex Data Object 2.x library" ET "Microsoft Dao 3.6 Objects librairy"
d ) Dans la procédure Test, tu dois définir 2 choses :
1- "C:AAA" représente le chemin où le répertoire
où sont tes fichiers. Ne pas oublier le
"" à la fin.
2- ThisWorkbook.Worksheets("Feuil2").Range("G10")
signifie tous tes données se retrouveront dans le même
classeur où tu as copié la macro, dans la feuille dont le
nom de l'onglet est "Feuil2", et la toute première cellule
de la plage sera la cellule G10
Tu peux modifier le nom de la feuille et l'adresse de cette
première cellule.
E ) Fais d'abord un test :
1- tu crées un nouveau répertoire et tu y copies seulement 2 fichiers
2 - dans ces 2 fichiers, tu t'assures que la feuille contenant le tableau
de tes données est la première feuille du classeur.
3 - Tu lances la macro "Test"
'------------------------------------------
Sub Test()
'Même classeur que la procédure, dans la Feuil2
'Extraire_Data_First_Excel_Sheet "c:AAA", _
ThisWorkbook.Worksheets("Feuil2").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 <> ""
'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=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
'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
'------------------------------------------
Je ne faisais pas référence au nom de fichier, mais au nom
de la feuille de chaque classeur dans laquelle sont tes données.
a ) Pour te simplifier la tâche, tu ouvres la fenêtre de l'éditeur de code
par le raccourci clavier Alt + F11
b ) Tu insères un module standard à partir du menu "Insertion" de la barre des menus.
c ) Tu y copies les procédures suivantes.
c ) Tu ajoutes les deux bibliothèques : Barre des menus / outils / références /
et tu les coches parmi la liste :
Microsoft Activex Data Object 2.x library" ET "Microsoft Dao 3.6 Objects librairy"
d ) Dans la procédure Test, tu dois définir 2 choses :
1- "C:AAA" représente le chemin où le répertoire
où sont tes fichiers. Ne pas oublier le
"" à la fin.
2- ThisWorkbook.Worksheets("Feuil2").Range("G10")
signifie tous tes données se retrouveront dans le même
classeur où tu as copié la macro, dans la feuille dont le
nom de l'onglet est "Feuil2", et la toute première cellule
de la plage sera la cellule G10
Tu peux modifier le nom de la feuille et l'adresse de cette
première cellule.
E ) Fais d'abord un test :
1- tu crées un nouveau répertoire et tu y copies seulement 2 fichiers
2 - dans ces 2 fichiers, tu t'assures que la feuille contenant le tableau
de tes données est la première feuille du classeur.
3 - Tu lances la macro "Test"
'------------------------------------------
Sub Test()
'Même classeur que la procédure, dans la Feuil2
'Extraire_Data_First_Excel_Sheet "c:AAA", _
ThisWorkbook.Worksheets("Feuil2").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 <> ""
'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=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
'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
'------------------------------------------
Je ne faisais pas référence au nom de fichier, mais au nom
de la feuille de chaque classeur dans laquelle sont tes données.
a ) Pour te simplifier la tâche, tu ouvres la fenêtre de l'éditeur de code
par le raccourci clavier Alt + F11
b ) Tu insères un module standard à partir du menu "Insertion" de la barre des menus.
c ) Tu y copies les procédures suivantes.
c ) Tu ajoutes les deux bibliothèques : Barre des menus / outils / références /
et tu les coches parmi la liste :
Microsoft Activex Data Object 2.x library" ET "Microsoft Dao 3.6 Objects librairy"
d ) Dans la procédure Test, tu dois définir 2 choses :
1- "C:AAA" représente le chemin où le répertoire
où sont tes fichiers. Ne pas oublier le
"" à la fin.
2- ThisWorkbook.Worksheets("Feuil2").Range("G10")
signifie tous tes données se retrouveront dans le même
classeur où tu as copié la macro, dans la feuille dont le
nom de l'onglet est "Feuil2", et la toute première cellule
de la plage sera la cellule G10
Tu peux modifier le nom de la feuille et l'adresse de cette
première cellule.
E ) Fais d'abord un test :
1- tu crées un nouveau répertoire et tu y copies seulement 2 fichiers
2 - dans ces 2 fichiers, tu t'assures que la feuille contenant le tableau
de tes données est la première feuille du classeur.
3 - Tu lances la macro "Test"
'------------------------------------------
Sub Test()
'Même classeur que la procédure, dans la Feuil2
'Extraire_Data_First_Excel_Sheet "c:AAA", _
ThisWorkbook.Worksheets("Feuil2").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 <> ""
'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=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
'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
'------------------------------------------