récupération de données de plusieurs classeurs

Le
Circé
Hello à tous !

Je dois écrire une macro qui récupère dans une feuille d'un même
classeur, les données situées sur la première feuilles d'une dizaine de
classeur.

Tous les classeurs ont la même structure, y a pas de problème de
doublons, c'est relativement simple. Je fais une macro qui boucle sur
tous les classeurs, les ouvre un par un, copie, ferme et colle.

N'y aurait-il pas un moyen plus élégant de récupérer ces données sans
ouvrir les classeurs
Avec Word (ben oui, c'est plus mon domaine) on a la méthode
InsertFile, il n'y a pas quelque chose d'équivalent avec Excel ?

Merci par avance ;)

Circé
http://faqword.free.fr
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Philippe.R
Le #4998781
Bonjour Circé,
Il y a chez Frédéric toute une série de solutions pour lire les classeurs
fermés :

http://frederic.sigonneau.free.fr/Ado.htm

--
http://www.excelabo.net/mpfe/connexion.php
http://dj.joss.free.fr/trombine.htm
Avec plaisir
Philippe.R
"Circé" news:
Hello à tous !

Je dois écrire une macro qui récupère dans une feuille d'un même classeur,
les données situées sur la première feuilles d'une dizaine de classeur.

Tous les classeurs ont la même structure, y a pas de problème de doublons,
c'est relativement simple. Je fais une macro qui boucle sur tous les
classeurs, les ouvre un par un, copie, ferme et colle.

N'y aurait-il pas un moyen plus élégant de récupérer ces données sans
ouvrir les classeurs...
Avec Word (ben oui, c'est plus mon domaine...) on a la méthode InsertFile,
il n'y a pas quelque chose d'équivalent avec Excel ?

Merci par avance ;)

Circé
http://faqword.free.fr




MichDenis
Le #4998761
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"

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

'Ne pas oublier le "" à la fin du nom du répertoire
'"c:AAA" -> répertoire à scanner
Extraire_Data_First_Excel_Sheet "c:AAA"

End Sub

'--------------------------------------
Sub Extraire_Data_First_Excel_Sheet(Chemin As String)

'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, Rg As Range
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
With Worksheets("Feuil1")
If .Range("A1") = "" Then
Set Rg = .Range("A1")
Else
Set Rg = .Range("A" & .Range("A65356").End(xlUp).Row)(2)
Ok = 1
End If
End With

'é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
'--------------------------------------




"Circé" Hello à tous !

Je dois écrire une macro qui récupère dans une feuille d'un même
classeur, les données situées sur la première feuilles d'une dizaine de
classeur.

Tous les classeurs ont la même structure, y a pas de problème de
doublons, c'est relativement simple. Je fais une macro qui boucle sur
tous les classeurs, les ouvre un par un, copie, ferme et colle.

N'y aurait-il pas un moyen plus élégant de récupérer ces données sans
ouvrir les classeurs...
Avec Word (ben oui, c'est plus mon domaine...) on a la méthode
InsertFile, il n'y a pas quelque chose d'équivalent avec Excel ?

Merci par avance ;)

Circé
http://faqword.free.fr
MichDenis
Le #4998741
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"


'------------------------------------------
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
'------------------------------------------





"Circé" Hello à tous !

Je dois écrire une macro qui récupère dans une feuille d'un même
classeur, les données situées sur la première feuilles d'une dizaine de
classeur.

Tous les classeurs ont la même structure, y a pas de problème de
doublons, c'est relativement simple. Je fais une macro qui boucle sur
tous les classeurs, les ouvre un par un, copie, ferme et colle.

N'y aurait-il pas un moyen plus élégant de récupérer ces données sans
ouvrir les classeurs...
Avec Word (ben oui, c'est plus mon domaine...) on a la méthode
InsertFile, il n'y a pas quelque chose d'équivalent avec Excel ?

Merci par avance ;)

Circé
http://faqword.free.fr
MichDenis
Le #4998721
Le classeur où seront copiées les données ne doit psa être dans le même
répertoire sinon, il va être scanné à son tour et les données obtenues
seront double. Dans le cas contraire, il est facile de modifier la procédure
pour en tenir compte.



"MichDenis" %
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"


'------------------------------------------
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
'------------------------------------------





"Circé" Hello à tous !

Je dois écrire une macro qui récupère dans une feuille d'un même
classeur, les données situées sur la première feuilles d'une dizaine de
classeur.

Tous les classeurs ont la même structure, y a pas de problème de
doublons, c'est relativement simple. Je fais une macro qui boucle sur
tous les classeurs, les ouvre un par un, copie, ferme et colle.

N'y aurait-il pas un moyen plus élégant de récupérer ces données sans
ouvrir les classeurs...
Avec Word (ben oui, c'est plus mon domaine...) on a la méthode
InsertFile, il n'y a pas quelque chose d'équivalent avec Excel ?

Merci par avance ;)

Circé
http://faqword.free.fr
JB
Le #4998651
Bonjour,

http://boisgontierjacques.free.fr/pages_site/GestionOnglets.htm#OngletsClas seursRepertoire

JB
http://boisgontierjacques.free.fr

On 23 oct, 23:13, Circé
Hello à tous !

Je dois écrire une macro qui récupère dans une feuille d'un même
classeur, les données situées sur la première feuilles d'une dizain e de
classeur.

Tous les classeurs ont la même structure, y a pas de problème de
doublons, c'est relativement simple. Je fais une macro qui boucle sur
tous les classeurs, les ouvre un par un, copie, ferme et colle.

N'y aurait-il pas un moyen plus élégant de récupérer ces donné es sans
ouvrir les classeurs...
Avec Word (ben oui, c'est plus mon domaine...) on a la méthode
InsertFile, il n'y a pas quelque chose d'équivalent avec Excel ?

Merci par avance ;)

Circéhttp://faqword.free.fr


Circé
Le #4998161
Bonjour

Un grand merci à tous les deux + Frédéric + Robert !

J'ai repris presque texto la macro de MichDenis, Ça fonctionne nickel,
nickel...
De plus, j'ai découvert plein de choses à ce sujet sur le site de
Frédéric ! Je suis épatée, ça dépasse mes espérances !!! :D)))

A bientôt, je crois que je vais avoir d'autres questions... ;))

Circé
http://faqword.free.fr

MichDenis a utilisé son clavier pour écrire :
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"


'------------------------------------------
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
'------------------------------------------





"Circé" Hello à tous !

Je dois écrire une macro qui récupère dans une feuille d'un même
classeur, les données situées sur la première feuilles d'une dizaine de
classeur.

Tous les classeurs ont la même structure, y a pas de problème de
doublons, c'est relativement simple. Je fais une macro qui boucle sur
tous les classeurs, les ouvre un par un, copie, ferme et colle.

N'y aurait-il pas un moyen plus élégant de récupérer ces données sans
ouvrir les classeurs...
Avec Word (ben oui, c'est plus mon domaine...) on a la méthode
InsertFile, il n'y a pas quelque chose d'équivalent avec Excel ?

Merci par avance ;)

Circé
http://faqword.free.fr


Circé
Le #4998131
Bonsoir Jacques,

Oupsss... Je n'avais pas vu ton message ! Le pire c'est que je
collectionne tous tes classeurs que je récupère chez Misange...
Donc j'en profite pour te remercier pour toutes tes bonnes paroles ;))

Circé
http://faqword.free.fr

Bonjour,

http://boisgontierjacques.free.fr/pages_site/GestionOnglets.htm#OngletsClasseursRepertoire

JB
http://boisgontierjacques.free.fr

On 23 oct, 23:13, Circé
Hello à tous !

Je dois écrire une macro qui récupère dans une feuille d'un même
classeur, les données situées sur la première feuilles d'une dizaine de
classeur.

Tous les classeurs ont la même structure, y a pas de problème de
doublons, c'est relativement simple. Je fais une macro qui boucle sur
tous les classeurs, les ouvre un par un, copie, ferme et colle.

N'y aurait-il pas un moyen plus élégant de récupérer ces données sans
ouvrir les classeurs...
Avec Word (ben oui, c'est plus mon domaine...) on a la méthode
InsertFile, il n'y a pas quelque chose d'équivalent avec Excel ?

Merci par avance ;)

Circéhttp://faqword.free.fr




Mgr.Abile
Le #4997761
Bonsoir,
Robert devrait être content, lui qui attendait des merci depuis au moins
deux ans !
;o))
--
Allez en paix
T.Abile
"Circé" news:
Bonjour

Un grand merci à tous les deux + Frédéric + Robert !

J'ai repris presque texto la macro de MichDenis, Ça fonctionne nickel,
nickel...
De plus, j'ai découvert plein de choses à ce sujet sur le site de Frédéric
! Je suis épatée, ça dépasse mes espérances !!! :D)))

A bientôt, je crois que je vais avoir d'autres questions... ;))

Circé
http://faqword.free.fr

MichDenis a utilisé son clavier pour écrire :
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"


'------------------------------------------
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
'------------------------------------------





"Circé" Hello à tous !

Je dois écrire une macro qui récupère dans une feuille d'un même
classeur, les données situées sur la première feuilles d'une dizaine de
classeur.

Tous les classeurs ont la même structure, y a pas de problème de
doublons, c'est relativement simple. Je fais une macro qui boucle sur
tous les classeurs, les ouvre un par un, copie, ferme et colle.

N'y aurait-il pas un moyen plus élégant de récupérer ces données sans
ouvrir les classeurs...
Avec Word (ben oui, c'est plus mon domaine...) on a la méthode
InsertFile, il n'y a pas quelque chose d'équivalent avec Excel ?

Merci par avance ;)

Circé
http://faqword.free.fr






bretsainclair Hors ligne
Le #25359542
Le mardi 23 Octobre 2007 à 23:13 par Circé :
Hello à tous !

Je dois écrire une macro qui récupère dans une feuille
d'un même
classeur, les données situées sur la première feuilles
d'une dizaine de
classeur.

Tous les classeurs ont la même structure, y a pas de problème de
doublons, c'est relativement simple. Je fais une macro qui boucle sur
tous les classeurs, les ouvre un par un, copie, ferme et colle.

N'y aurait-il pas un moyen plus élégant de
récupérer ces données sans
ouvrir les classeurs...
Avec Word (ben oui, c'est plus mon domaine...) on a la méthode
InsertFile, il n'y a pas quelque chose d'équivalent avec Excel ?

Merci par avance ;)

Circé
http://faqword.free.fr


Bonjour,
J'ai utilisé ce code presque à l'identique car il correspond tout à fait à mes besoins.
Je stocke des fichiers excel et cette macro me permet de les fusionner en un seul.
Mais maintenant, je remplace mon espace de stockage par un espace sharepoint.
Le chemin pour trouver les fichiers n'est donc plus de la forme "c:AAA", mais une url de type "http://shp.itn.nom/sites/zzext/"
En changeant le chemin par l'url, ça ne fonctionne pas. Evidemment, la fonction dir est inadaptée aussi...
Bref, je n'arrive pas à adapter cette macro dans le cas où les fichiers sont stockés sur le "cloud" (accessible par une url) au lieu d'un répertoire sur le disque.
Avez-vous une solution à me proposer?
Publicité
Poster une réponse
Anonyme