Lister et récupérer plusieur donnés d'un dossier
Bonjour à tous,
Je viens chercher vos lumières concernant un sujet que je ne saurais résoudre, car je suis entièrement novice dans le Vba.
Je vous explique ce que j'aimerais faire.
J'ai un dossier Windows, avec dedans un certain nombre de fichier excel (dossier1.xls, dossier2.xls, projet1.xls, ...) qui se ressemble en tout point dans leur conception, c'est a dire une feuille sommaire, une feuille projet et une feuille ressource.
J'aimerais créer un fichier "récap.xls" qui me permettrais, quand je clique sur un bouton, de récupérer toutes les données comprises entre la cellule B2 et J150 de ma feuille ressource et ceci sur l'ensemble des fichiers excel de mon dossier (liste ci-dessus comme exemple).
Est-ce faisable ? Merci pour votre aide si précieuse.
Ben
Bonjour Chimonito,
Oui c'est faisable mais demande quelques renseignements supplémentaires.
1. Le fichier Récap va contenir une macro. Doit-il garder l'extension .xls ou devient-il un .xlsm ?
2. Où sera le fichier récap, dans le même dossier ?
3. Il nous faut le chemin d'accès complet à ton dossier !
4. Ce dossier contient-il uniquement les fichiers à ouvrir ?
5. Peut-il contenir d'autres fichiers ? Si Oui, comment les différencier ?
6. Les données extraites seront placées les unes en-dessous des autres, fichier après fichier ?
En attendant, un code à adapter :
Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim NF As String 'déclare la variable NF (Nom du Fichier)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Set CD = ThisWorkbook 'définit le classeur destination CD
CH = "C:\Users\Cimonito\Documents\" 'définit le chemin d'accès CH (à adapter à ton cas) ou ligne au dessous
'CH=ThisWorkbook.Path & "\" si le classeur recup.xls se trouve dans le même dossier
Set OD = CD.Sheets("Feuil1") 'définit l'onglet destination OD (à adapter à ton cas)
NF = Dir(CH & "*.xls") 'définit le nom du fichier NF (première occurrence)
Do While NF <> "" 'exécute tant qu'il existe des fichiers
If NF <> "recp.xls" Then 'condition 1 : si le nom du fichier n'est pas "recup.xls"
'condition 2 : si l'etension du fichier est ".xls", ouvre le fichier NF
If Right(NF, 4) = ".xls" Then Application.Workbooks.Open (CH & NF)
Set CS = ActiveWorkbook 'définit le classeur source CS
Set OS = CS.Sheets("ressource") 'définit l'onglet source OS
'définit la cellue de destination DEST (A1, si A1 est vide, sinon la première cellule vide de la colonne A de l'onglert OD)
Set DEST = IIf(OD.Range("A1").Value = "", OD.Range("A1"), OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
OS.Range("B2:J150").Copy DEST 'copie la plage B1:J150 de l'onglet source et la colle dans DEST
CS.Close SaveChanges:=False 'ferme le classeur source CXS sans enregister
End If 'fin de la condition 2
End If 'fin de la condition 1
NF = Dir 'définit le nom du fichier NF (occurrence suivante)
Loop 'boucle
MsgBox "Transfert des données terminé !" 'message de fin
End SubMerci pour les infos, alors le fichier recap sera dans le même dossier et peut s'appeler xlsm. Ce dossier contiendra uniquement les fichiers a extraire. On peut appeler ce dossier archive et il se situe sur le bureau.
Les informations se trouveront effectivement les unes sous les autres.
Merci de votre aide.
Bonjour Chimonito, bonjour le forum,
Le code proposé au-dessus était pratiquement le bon. Copie le nouveau code ci-dessous dans un module standard du fichier recap et enregistre-le (xlsm de préférence). Lance la macro, les données seront récupérées et renvoyées dans le premier onglet de recap.xlms, les unes en-dessous des autres...
Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim NF As String 'déclare la variable NF (Nom du Fichier)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
CH = ThisWorkbook.Path & "\" 'définit le chemin d'accès CH
Set OD = CD.Sheets(1) 'définit l'onglet destination OD, le premier onglet du classeur (à adapter à ton cas)
NF = Dir(CH & "*.xls") 'définit le nom du fichier NF (première occurrence)
Do While NF <> "" 'exécute tant qu'il existe des fichiers
If NF <> "recp.xls" Then 'condition 1 : si le nom du fichier n'est pas "recup.xls"
'condition 2 : si l'etension du fichier est ".xls", ouvre le fichier NF
If Right(NF, 4) = ".xls" Then Application.Workbooks.Open (CH & NF)
Set CS = ActiveWorkbook 'définit le classeur source CS
Set OS = CS.Sheets("ressource") 'définit l'onglet source OS
'définit la cellue de destination DEST (A1, si A1 est vide, sinon la première cellule vide de la colonne A de l'onglert OD)
Set DEST = IIf(OD.Range("A1").Value = "", OD.Range("A1"), OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
OS.Range("B2:J150").Copy DEST 'copie la plage B1:J150 de l'onglet source et la colle dans DEST
CS.Close SaveChanges:=False 'ferme le classeur source CXS sans enregister
End If 'fin de la condition 2
End If 'fin de la condition 1
NF = Dir 'définit le nom du fichier NF (occurrence suivante)
Loop 'boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Transfert des données terminé !" 'message de fin
End SubJ'essaye plus tard, en attendant merci
Bonjour, je viens d'essayer le code en le mettant dans un module et il me met une erreur de compilation "End If sans bloc if"
en me surlignant le End If de la condition 1.
Voici le code modifier par mes soins au niveau de la destination:
Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim NF As String 'déclare la variable NF (Nom du Fichier)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
CH = ThisWorkbook.Path & "c:\mondossier\" 'définit le chemin d'accès CH
Set OD = CD.Sheets(1) 'définit l'onglet destination OD, le premier onglet du classeur (à adapter à ton cas)
NF = Dir(CH & "*.xls") 'définit le nom du fichier NF (première occurrence)
Do While NF <> "" 'exécute tant qu'il existe des fichiers
If NF <> "recap.xlsm" Then 'condition 1 : si le nom du fichier n'est pas "recap.xlsm"
'condition 2 : si l'etension du fichier est ".xls", ouvre le fichier NF
If Right(NF, 4) = ".xls" Then Application.Workbooks.Open (CH & NF)
Set CS = ActiveWorkbook 'définit le classeur source CS
Set OS = CS.Sheets("ressource") 'définit l'onglet source OS
'définit la cellue de destination DEST (A1, si A1 est vide, sinon la première cellule vide de la colonne A de l'onglert OD)
Set DEST = IIf(OD.Range("A1").Value = "", OD.Range("A1"), OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
OS.Range("B2:J150").Copy DEST 'copie la plage B1:J150 de l'onglet source et la colle dans DEST
CS.Close SaveChanges:=False 'ferme le classeur source CXS sans enregister
End If 'fin de la condition 2
End If 'fin de la condition 1
NF = Dir 'définit le nom du fichier NF (occurrence suivante)
Loop 'boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Transfert des données terminé !" 'message de fin
End SubBonjour Chimonito, bonjour le forum,
En effet il y avait une erreur de syntaxe. Voici le code corrigé :
Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim NF As String 'déclare la variable NF (Nom du Fichier)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
CH = ThisWorkbook.Path & "c:\mondossier\" 'définit le chemin d'accès CH
Set OD = CD.Sheets(1) 'définit l'onglet destination OD, le premier onglet du classeur (à adapter à ton cas)
NF = Dir(CH & "*.xls") 'définit le nom du fichier NF (première occurrence)
Do While NF <> "" 'exécute tant qu'il existe des fichiers
If NF <> "recap.xlsm" Then 'condition 1 : si le nom du fichier n'est pas "recap.xlsm"
If Right(NF, 4) = ".xls" Then 'condition 2 : si l'extension du fichier est ".xls"
Application.Workbooks.Open (CH & NF) 'ouvre le fichier NF
Set CS = ActiveWorkbook 'définit le classeur source CS
Set OS = CS.Sheets("ressource") 'définit l'onglet source OS
'définit la cellue de destination DEST (A1, si A1 est vide, sinon la première cellule vide de la colonne A de l'onglert OD)
Set DEST = IIf(OD.Range("A1").Value = "", OD.Range("A1"), OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
OS.Range("B2:J150").Copy DEST 'copie la plage B1:J150 de l'onglet source et la colle dans DEST
CS.Close SaveChanges:=False 'ferme le classeur source CXS sans enregister
End If 'fin de la condition 2
End If 'fin de la condition 1
NF = Dir 'définit le nom du fichier NF (occurrence suivante)
Loop 'boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Transfert des données terminé !" 'message de fin
End SubSalut en effet cela marche mieux, je te remercie pour ta réactivité.
Maintenant j'ai une erreur d'exécution 52 " Nom ou numéro de fichier incorrect"
Bonjour Chimonito, bonjour le forum,
Désolé mais là je ne vois pas !... Il te faut voir ce que vaut NF au moment du bug et peut-être tu auras la réponse...
Je viens de changer la ligne ci dessous comme ceci
NF = Dir("CH & *.xls")Du coup j'obtiens bien. " Transfert des données terminé ", mais quand je regarde sur ma feuille 1, je n'ai rien.
Bonsoir Chimonito, bonsoir le forum,
Non ! CH étant une variable tu ne peux pas écrire :
NF = Dir("CH & *.xls")ce qui est correct c'est bien :
NF = Dir(CH & "*.xls")J'avais testé le code en créant un dossier que j'avais appelé Poubelle dans lequel je n'avais mis que deux fichiers et ça marchait. Je vais essayer d'en mettre beaucoup plus et refaire des tests et je reviens vers toi...
Bonsoir Chimano, bonsoir le forum,
Il y avait en effet une erreur je te demandais d'enregistrer le fichier sour : recap.xlsm et dans le code j'écrivais recap.xls.
En corrigeant cette erreur et avec plus de 40 fichiers chez moi je n'ai pas eu de problème.
Le code modifié :
Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim NF As String 'déclare la variable NF (Nom du Fichier)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
CH = ThisWorkbook.Path & "\" 'définit le chemin d'accès CH
Set OD = CD.Sheets(1) 'définit l'onglet destination OD, le premier onglet du classeur (à adapter à ton cas)
NF = Dir(CH & "*.xls") 'définit le nom du fichier NF (première fichier du dossier ayant CH comme chemin d'accès)
Do While NF <> "" 'exécute tant qu'il existe des fichiers
If NF <> "recap.xlms" Then 'condition 1 : si le nom du fichier n'est pas "recap.xlms"
If Right(NF, 4) = ".xls" Then 'condition 2 : si l'etension du fichier est ".xls"
Application.Workbooks.Open (CH & NF) 'ouvre le fichier NF
Set CS = ActiveWorkbook 'définit le classeur source CS
Set OS = CS.Sheets("ressource") 'définit l'onglet source OS
'définit la cellue de destination DEST (A1, si A1 est vide, sinon la première cellule vide de la colonne A de l'onglert OD)
Set DEST = IIf(OD.Range("A1").Value = "", OD.Range("A1"), OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
OS.Range("B2:J150").Copy DEST 'copie la plage B1:J150 de l'onglet source et la colle dans DEST
CS.Close SaveChanges:=False 'ferme le classeur source CS sans enregister
End If 'fin de la condition 2
End If 'fin de la condition 1
NF = Dir 'définit le nom du fichier NF (fichier suivant du dossier ayant CH comme chemin d'accès )
Loop 'boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Transfert des données terminé !" 'message de fin
End SubCoucou tous le monde,
Merci cela marche a ravir, tu es vraiment un Boss !!!
Maintenant est-ce possible de faire la même chose, mais en ignorant les lignes vide ?
En tous cas merci c'est super cool !
Bonjour Chimonito, bonjour le forum,
Essaie comme ça (ça risque d'être plus long...) :
Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim NF As String 'déclare la variable NF (Nom du Fichier)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim PL As Range 'déclare la variable PL (PLage)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
CH = ThisWorkbook.Path & "\" 'définit le chemin d'accès CH
Set OD = CD.Sheets(1) 'définit l'onglet destination OD, le premier onglet du classeur (à adapter à ton cas)
NF = Dir(CH & "*.xls") 'définit le nom du fichier NF (première fichier du dossier ayant CH comme chemin d'accès)
Do While NF <> "" 'exécute tant qu'il existe des fichiers
If NF <> "recap.xlms" Then 'condition 1 : si le nom du fichier n'est pas "recap.xlms"
If Right(NF, 4) = ".xls" Then 'condition 2 : si l'etension du fichier est ".xls"
Application.Workbooks.Open (CH & NF) 'ouvre le fichier NF
Set CS = ActiveWorkbook 'définit le classeur source CS
Set OS = CS.Sheets("ressource") 'définit l'onglet source OS
TC = OS.Range("B1:J150") 'définit le tableau de cellules TC
Set PL = OS.Range("A1") 'initialise la plage PL
For I = 2 To UBound(TC, 1) 'boucle sur toutes les lignes I du tableau de cellules TC (en partant de la seconde)
For J = 1 To UBound(TC, 2) 'boucle sur toutes les colonnes J du tableau de cellules TC
If TC(I, J) <> "" Then 'condition 'si la valeur en ligne I, colonne J de TC n'est pas vide
'redéfinit la plage PL (la ligne I si PL ne contient qu'une seule cellule, sinon l'union de PL et de la ligne I)
Set PL = IIf(PL.Cells.Count = 1, OS.Rows(I), Application.Union(PL, OS.Rows(I)))
Exit For 'sort de la boucle 2
End If 'fin de la condition
Next J 'prochaine colonne de la boucle 2
Next I 'prochaine ligne de la boucle 1
'définit la cellue de destination DEST (A1, si A1 est vide, sinon la première cellule vide de la colonne A de l'onglert OD)
Set DEST = IIf(OD.Range("A1").Value = "", OD.Range("A1"), OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
PL.Copy DEST 'copie la plage PL de l'onglet source et la colle dans DEST
CS.Close SaveChanges:=False 'ferme le classeur source CS sans enregister
End If 'fin de la condition 2
End If 'fin de la condition 1
NF = Dir 'définit le nom du fichier NF (fichier suivant du dossier ayant CH comme chemin d'accès )
Loop 'boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Transfert des données terminé !" 'message de fin
End SubMerci je teste dès que je peux
Je viens de tester et ça ne se passe pas comme le précédent code.
Il ne me copie qu'un seul fichier et il ne me met rien dans la cellule A1 mais il commence en B3
Bonjour chimonito, bonjour le forum,
Je ne comprends pas, le code semble correct... Pourrais-tu mettre en pièce jointe un fichier source ou, si il contient des données confidentielles, un fichier exemple ayant la même structure qu'un fichier source.
Je te fais parvenir ci-joint un dossier exemple.
Dans la feuille récap.xlsm 3 onglets :
- 1 pour faire le test de ton code
- 1 pour voir le résultat si tu ne veux pas le tester
- et le dernier pour ce que j'aimerais que ça donne si cela est faisable. Par la même occasion si on peut ajouter la bordure horizontale en fin de chaque bâtiment. Tu comprendras en regardant mon fichier.
Je te remercie en tous cas pour tous tes efforts, c'est déjà énorme ce que tu as fait.
MErci encore
Benjamin
Bonjour Benjamin, bonjour le forum,
En pièce jointe le fichier recap.xlsm avec le code modifié. La macro commence par effacer d'éventuelles anciennes données dans le premier onglet de recap puis, récupère les données fichier après fichier. Seul soucis le format qui n'est pas appliqué mais les tests semblent concluants...
Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim CH As String 'déclare la variable CH (CHemin d'accès)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim NF As String 'déclare la variable NF (Nom du Fichier)
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DL As Integer 'déclare la variable DL (Dernière ligne)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim K As Integer 'déclare la variable K (incrément)
Dim I As Integer 'déclare la variable I (incrément)
Dim J As Byte 'déclare la variable J (incrément)
Dim L As Byte 'déclare la variable L (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau de Lignes)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
CH = ThisWorkbook.Path & "\" 'définit le chemin d'accès CH
Set OD = CD.Sheets(1) 'définit l'onglet destination OD, le premier onglet du classeur (à adapter à ton cas)
OD.Range("A1").CurrentRegion.Offset(1, 0).Clear 'efface les anciennes données
NF = Dir(CH & "*.xls") 'définit le nom du fichier NF (première fichier du dossier ayant CH comme chemin d'accès)
Do While NF <> "" 'exécute tant qu'il existe des fichiers
If NF <> "recap.xlsm" Then 'condition 1 : si le nom du fichier n'est pas "recap.xlsm"
If Right(NF, 4) = ".xls" Then 'condition 2 : si l'extension du fichier est ".xls"
Erase TL 'efface le tableau de ligne TL
Application.Workbooks.Open (CH & NF) 'ouvre le fichier NF
Set CS = ActiveWorkbook 'définit le classeur source CS
Set OS = CS.Sheets("rapport") 'définit l'onglet source OS
DL = OS.Cells(Application.Rows.Count, 2).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 2 (=B) de l'onglet OS
TC = OS.Range("B8:G" & DL) 'définit le tableau de cellules TC (on part de la ligne 8 et jusqu'à la colonne G pas J !)
K = 1 'initialise la variable K
For I = 1 To UBound(TC, 1) 'boucle 1 : sur toutes les lignes I du tableau de cellules TC
For J = 1 To UBound(TC, 2) 'boucle 2 : sur toutes les colonnes J du tableau de cellules TC
If TC(I, J) <> "" Then 'condition 'si la valeur en ligne I, colonne J de TC n'est pas vide
ReDim Preserve TL(1 To 6, 1 To K) 'redimensionne le tableau TL (6 lignes, K colonnes)
For L = 1 To 6 'boucle 3 : sur les 6 colonnes de la ligne
TL(L, K) = TC(I, L) 'récupère dans la ligne L de TL la valeur de la colonne L de TC (Transposition)
Next L 'prochaine colonne de la boucle 3
K = K + 1 'incrémente K (ajoute une colonne à TL)
Exit For 'sort de la boucle2
End If 'fin de la condition
Next J 'prochaine colonne de la boucle 2
Next I 'prochaine ligne de la boucle 1
'définit la cellue de destination DEST (A1, si A1 est vide, sinon la première cellule vide de la colonne A de l'onglert OD)
Set DEST = OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0)
DEST.Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL) 'transpose le tableau TL dans DEST redimensionnée
CS.Close SaveChanges:=False 'ferme le classeur source CS sans enregister
End If 'fin de la condition 2
End If 'fin de la condition 1
NF = Dir 'définit le nom du fichier NF (fichier suivant du dossier ayant CH comme chemin d'accès )
Loop 'boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Transfert des données terminé !" 'message de fin
End Sub