Tous les fichiers d'un répertoire

Bonjour,

Prend les champs A8:A100 et les copie dans la colonne A.

Sub syntèseClasseursBD()
sousRépertoire = "BD"
[A2].Select
fenetre = ActiveWorkbook.Name
ChDir ActiveWorkbook.Path
nf = Dir(sousRépertoire & "*.xls") ' premier fichier
Do While nf <> ""
Workbooks.Open Filename:=sousRépertoire & "" & nf
Windows(fenetre).Activate
Workbooks(nf).ActiveSheet.[A8:A100].Copy ActiveCell
Workbooks(nf).Close False
[A1].End(xlDown).Offset(1, 0).Select
nf = Dir ' fichier suivant
Loop
End Sub

Prend les champs A8:A100 et les copie dans les colonnes A,B,C,

Sub syntèseClasseursBD2()
sousRépertoire = "BD"
[A2].Select
fenetre = ActiveWorkbook.Name
ChDir ActiveWorkbook.Path
nf = Dir(sousRépertoire & "*.xls") ' premier fichier
Do While nf <> ""
Workbooks.Open Filename:=sousRépertoire & "" & nf
Windows(fenetre).Activate
Workbooks(nf).ActiveSheet.[A8:A100].Copy ActiveCell
Workbooks(nf).Close False
[A2].Offset(0, 1).Select
nf = Dir ' fichier suivant
Loop
End Sub


JB
http://boisgontierjacques.free.fr


On 25 sep, 13:41, JulieH <jul...@discussions.microsoft.com> wrote:

Bonjour à toutes et tous,

J'ai un répertoire avec environ 10 fichiers.
A partir d'un fichier ouvert (macro - bouton) issu d'un autre
répertoire, je voudrais aller rechercher la même zone "Range
("A8:A100")" dans tous les fichiers du répertoire pour les copier dans
mon fichier en cours.
J'ai réussi à lister tous les fichiers du répertoire mais e nsuite, je
m'y perd un peu avec "For each".

Merci d'avance pour vos idées.

Julie

bonjour Julie,

x = 1
'boucle sur Tous les fichiers d'un répertoire

For ligne = 8 To 100
Cells(x, 1) = ExecuteExcel4Macro _
("'" & rep & "[" & Fichier & "]Feuil1'!R" & ligne & "C1")
x = x + 1
Next

' Fin boucle Tous les fichiers d'un répertoire

isabelle

Bonjour à toutes et tous,

J'ai un répertoire avec environ 10 fichiers.
A partir d'un fichier ouvert (macro - bouton) issu d'un autre
répertoire, je voudrais aller rechercher la même zone "Range
("A8:A100")" dans tous les fichiers du répertoire pour les copier dans
mon fichier en cours.
J'ai réussi à lister tous les fichiers du répertoire mais ensuite,
je m'y perd un peu avec "For each".

Merci d'avance pour vos idées.

Julie

Bonjour à tous les deux et merci pour vos réponses,

J'ai plutôt opté pour la solution de JB qui ressemble plus à ce que
j'imaginais.
En revanche, j'avais oublié de préciser qu'il faut copier en colonne A
mais à la suite. C'est à dire le fichier 1 de A8 à Ax, le fichier 2 de
Ax+1 à Ay...

Julie

bonjour Julie,

x = 1
'boucle sur Tous les fichiers d'un répertoire

For ligne = 8 To 100
Cells(x, 1) = ExecuteExcel4Macro _
("'" & rep & "[" & Fichier & "]Feuil1'!R" & ligne & "C1")
x = x + 1
Next

' Fin boucle Tous les fichiers d'un répertoire

isabelle

Bonjour à toutes et tous,

J'ai un répertoire avec environ 10 fichiers.
A partir d'un fichier ouvert (macro - bouton) issu d'un autre
répertoire, je voudrais aller rechercher la même zone "Range
("A8:A100")" dans tous les fichiers du répertoire pour les copier dans
mon fichier en cours.
J'ai réussi à lister tous les fichiers du répertoire mais ensuite,
je m'y perd un peu avec "For each".

Merci d'avance pour vos idées.

Julie

Mon dernier mail est sans objet. En effet mon premier test n'avait pas
fonctionné pour cause de ligne vide dans la plage à copier. J'ai
remplacé par [A65000] et xlup.

Merci encore

Julie

Bonjour,

Prend les champs A8:A100 et les copie dans la colonne A.

Sub syntèseClasseursBD()
sousRépertoire = "BD"
[A2].Select
fenetre = ActiveWorkbook.Name
ChDir ActiveWorkbook.Path
nf = Dir(sousRépertoire & "*.xls") ' premier fichier
Do While nf <> ""
Workbooks.Open Filename:=sousRépertoire & "" & nf
Windows(fenetre).Activate
Workbooks(nf).ActiveSheet.[A8:A100].Copy ActiveCell
Workbooks(nf).Close False
[A1].End(xlDown).Offset(1, 0).Select
nf = Dir ' fichier suivant
Loop
End Sub

Prend les champs A8:A100 et les copie dans les colonnes A,B,C,

Sub syntèseClasseursBD2()
sousRépertoire = "BD"
[A2].Select
fenetre = ActiveWorkbook.Name
ChDir ActiveWorkbook.Path
nf = Dir(sousRépertoire & "*.xls") ' premier fichier
Do While nf <> ""
Workbooks.Open Filename:=sousRépertoire & "" & nf
Windows(fenetre).Activate
Workbooks(nf).ActiveSheet.[A8:A100].Copy ActiveCell
Workbooks(nf).Close False
[A2].Offset(0, 1).Select
nf = Dir ' fichier suivant
Loop
End Sub


JB
http://boisgontierjacques.free.fr


On 25 sep, 13:41, JulieH <jul...@discussions.microsoft.com> wrote:

Bonjour à toutes et tous,

J'ai un répertoire avec environ 10 fichiers.
A partir d'un fichier ouvert (macro - bouton) issu d'un autre
répertoire, je voudrais aller rechercher la même zone "Range
("A8:A100")" dans tous les fichiers du répertoire pour les copier dans
mon fichier en cours.
J'ai réussi à lister tous les fichiers du répertoire mais ensuite, je
m'y perd un peu avec "For each".

Merci d'avance pour vos idées.

Julie

Sub syntèseClasseursBD()
sousRépertoire = "BD"
[A2].Select
fenetre = ActiveWorkbook.Name
ChDir ActiveWorkbook.Path
nf = Dir(sousRépertoire & "*.xls") ' premier fichier
Do While nf <> ""
Workbooks.Open Filename:=sousRépertoire & "" & nf
Windows(fenetre).Activate
Workbooks(nf).ActiveSheet.[A8:A100].Copy ActiveCell
Workbooks(nf).Close False
[A65000].End(xlUp).Offset(1, 0).Select
nf = Dir ' fichier suivant
Loop
End Sub

JB



On 25 sep, 15:04, JulieH <jul...@discussions.microsoft.com> wrote:

Bonjour à tous les deux et merci pour vos réponses,

J'ai plutôt opté pour la solution de JB qui ressemble plus à ce que
j'imaginais.
En revanche, j'avais oublié de préciser qu'il faut copier en colonne A
mais à la suite. C'est à dire le fichier 1 de A8 à Ax, le fichier 2 de
Ax+1 à Ay...

Julie

bonjour Julie,

x = 1
'boucle sur Tous les fichiers d'un répertoire

For ligne = 8 To 100
Cells(x, 1) = ExecuteExcel4Macro _
("'" & rep & "[" & Fichier & "]Feuil1'!R" & ligne & "C1")
x = x + 1
Next

' Fin boucle Tous les fichiers d'un répertoire

isabelle

Bonjour à toutes et tous,

J'ai un répertoire avec environ 10 fichiers.
A partir d'un fichier ouvert (macro - bouton) issu d'un autre
répertoire, je voudrais aller rechercher la même zone "Range
("A8:A100")" dans tous les fichiers du répertoire pour les copier da ns
mon fichier en cours.
J'ai réussi à lister tous les fichiers du répertoire mais en suite,
je m'y perd un peu avec "For each".

Merci d'avance pour vos idées.

Julie- Masquer le texte des messages précédents -

- Afficher le texte des messages précédents -

Il est possible de ton extraire sans ouvrir un fichier :


Fonction disponible sur le site de Frédéric Sigonneau
Nécessite une référence à la bibliothèque
"Microsoft ActiveX Data Objects 2.x Library"

'---------------------------------
Function GetValueWithADO(Classeur$, Feuille$, CellAdresse$) As Variant
Dim rcdSet As New ADODB.Recordset
Dim strConn As String
Dim strCmd As String
Dim dummyBase As Range

'prépare une "base de données" bidon pour la clause SELECT
'(une entête fictive et une ligne de données)
Set dummyBase = Range(CellAdresse)

'prépare les commandes ADO
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Classeur & ";" & _
"Extended Properties=""Excel 8.0;HDR=No;IMEX=1;"";"
strCmd = "SELECT F1 FROM [" & Feuille & "$" & dummyBase.Address(0, 0) & "] Where not isnull(F1) "

'va chercher l'info
rcdSet.Open strCmd, strConn, adOpenStatic, adLockReadOnly, adCmdText
X = rcdSet.RecordCount
GetValueWithADO = Application.Clean(rcdSet.GetRows(X))

End Function
'---------------------------------


Sub test()

Dim Fich As String, Feuil As String, CellAdr As String
Dim Répertoire As String, A As Integer, T As Long, X

'Répertoire de ton choix
Répertoire = "c:AAA"
'le nom de la feuille doit être le même pour chaque fichier
Feuil = "Feuil1"
'La plage de cellule à extraire de ton fichier
'la procédure a été conçu pour une colonne, celle de ton choix
CellAdr = "A15:A20"
On Error Resume Next
If Dir(Répertoire, vbDirectory) <> "" Then
Fich = Dir(Répertoire & "*.xls")
Do While Fich <> ""
A = A + 1
With ThisWorkbook
With .Worksheets("Feuil1")
X = GetValueWithADO(Fich, Feuil, CellAdr)
T = UBound(X)
s = X(4)
'à partir où les données seront copiées
.Range("A4").Resize(T).Columns(A) = _
Application.Transpose(X)
Erase X
End With
End With
Fich = Dir()
Loop
End If
End Sub





"JulieH" <julieh@discussions.microsoft.com> a écrit dans le message de news:
eQ9xNk2$HHA.536@TK2MSFTNGP06.phx.gbl...
Bonjour à toutes et tous,

J'ai un répertoire avec environ 10 fichiers.
A partir d'un fichier ouvert (macro - bouton) issu d'un autre
répertoire, je voudrais aller rechercher la même zone "Range
("A8:A100")" dans tous les fichiers du répertoire pour les copier dans
mon fichier en cours.
J'ai réussi à lister tous les fichiers du répertoire mais ensuite, je
m'y perd un peu avec "For each".

Merci d'avance pour vos idées.

Julie

Merci également pour cette réponse très complète.

Julie

Il est possible de ton extraire sans ouvrir un fichier :


Fonction disponible sur le site de Frédéric Sigonneau
Nécessite une référence à la bibliothèque
"Microsoft ActiveX Data Objects 2.x Library"

'---------------------------------
Function GetValueWithADO(Classeur$, Feuille$, CellAdresse$) As Variant
Dim rcdSet As New ADODB.Recordset
Dim strConn As String
Dim strCmd As String
Dim dummyBase As Range

'prépare une "base de données" bidon pour la clause SELECT
'(une entête fictive et une ligne de données)
Set dummyBase = Range(CellAdresse)

'prépare les commandes ADO
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Classeur & ";" & _
"Extended Properties=""Excel 8.0;HDR=No;IMEX=1;"";"
strCmd = "SELECT F1 FROM [" & Feuille & "$" & dummyBase.Address(0, 0) & "] Where not isnull(F1) "

'va chercher l'info
rcdSet.Open strCmd, strConn, adOpenStatic, adLockReadOnly, adCmdText
X = rcdSet.RecordCount
GetValueWithADO = Application.Clean(rcdSet.GetRows(X))

End Function
'---------------------------------


Sub test()

Dim Fich As String, Feuil As String, CellAdr As String
Dim Répertoire As String, A As Integer, T As Long, X

'Répertoire de ton choix
Répertoire = "c:AAA"
'le nom de la feuille doit être le même pour chaque fichier
Feuil = "Feuil1"
'La plage de cellule à extraire de ton fichier
'la procédure a été conçu pour une colonne, celle de ton choix
CellAdr = "A15:A20"
On Error Resume Next
If Dir(Répertoire, vbDirectory) <> "" Then
Fich = Dir(Répertoire & "*.xls")
Do While Fich <> ""
A = A + 1
With ThisWorkbook
With .Worksheets("Feuil1")
X = GetValueWithADO(Fich, Feuil, CellAdr)
T = UBound(X)
s = X(4)
'à partir où les données seront copiées
.Range("A4").Resize(T).Columns(A) = _
Application.Transpose(X)
Erase X
End With
End With
Fich = Dir()
Loop
End If
End Sub





"JulieH" <julieh@discussions.microsoft.com> a écrit dans le message de news:
eQ9xNk2$HHA.536@TK2MSFTNGP06.phx.gbl...
Bonjour à toutes et tous,

J'ai un répertoire avec environ 10 fichiers.
A partir d'un fichier ouvert (macro - bouton) issu d'un autre
répertoire, je voudrais aller rechercher la même zone "Range
("A8:A100")" dans tous les fichiers du répertoire pour les copier dans
mon fichier en cours.
J'ai réussi à lister tous les fichiers du répertoire mais ensuite, je
m'y perd un peu avec "For each".

Merci d'avance pour vos idées.

Julie

Dans la procédure initile présentée, certains usagers
peuvent éprover des difficultés avec cette ligne de code :

Si le répertoire courant est celui d'où on extrait les données
Cette ligne de code peut s'écrire comme ceci :
X = GetValueWithADO(Fich, Feuil, CellAdr)

SINON, ELLE S'ÉCRIT DE CETTE FAÇON :
X = GetValueWithADO(Répertoire & Fich, Feuil, CellAdr)
(cette méthode est plus prudente !)


'----------------------------------------
Sub test()

Dim Fich As String, Feuil As String, CellAdr As String
Dim Répertoire As String, A As Integer, T As Long, X
Dim ModeCalcul As String

'Répertoire de ton choix
Répertoire = "c:AAA"

'le nom de la feuille doit obligatoirement
'être le même pour chaque fichier de ton répertoire
Feuil = "Feuil1"

'La plage de cellule à extraire de ton fichier
'la procédure a été conçu pour une colonne, celle de ton choix
CellAdr = "A15:A20"

On Error Resume Next
If Dir(Répertoire, vbDirectory) <> "" Then
Application.ScreenUpdating = False
ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Fich = Dir(Répertoire & "*.xls")
Do While Fich <> ""
A = A + 1
With ThisWorkbook
'Nom de la feuille où sont copiées les données
With .Worksheets("Feuil1")
X = GetValueWithADO(Répertoire & Fich, Feuil, CellAdr)
T = UBound(X)
'à partir où les données seront copiées
.Range("A4").Resize(T).Columns(A) = _
Application.Transpose(X)
Erase X
End With
End With
Fich = Dir()
Loop
End If
Application.Calculation = ModeCalcul
End Sub
'----------------------------------------

En passant, la fonction initiale de M.Sigonneau a été modifié
pour pouvoir accepter une colonne affichant des données soit de
type Numérique ou Alphanumérique ou les 2 combinées. De plus,
Elle ne tient pas compte des cellules vides de la colonne dont sont
extraites les données. De même, quelques lignes de code ont été
coupées.

'-----------------------------------------------
Function GetValueWithADO(Classeur$, Feuille$, CellAdresse$)
Dim rcdSet As New ADODB.Recordset
Dim strConn As String, strCmd As String

'Chaîne de connection au classeur excel déterminé.
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Classeur & ";" & _
"Extended Properties=""Excel 8.0;HDR=No;IMEX=1;"";"

'Définition de la requête à exécuter sur le classeur
strCmd = "SELECT F1 FROM [" & Feuille & "$" & CellAdresse$ & _
"] Where not isnull(F1) "

'Exécution de la requête
rcdSet.Open strCmd, strConn, adOpenStatic, adLockReadOnly, adCmdText
'extraire dans un tableau, le RecordSet généré par la requête
GetValueWithADO = Application.Clean(rcdSet.GetRows(rcdSet.RecordCount))

End Function
'-----------------------------------------------