Boucle ouverture fichier dans sous dossier
Bonjour,
Avec l'aide d'un membre actif du forum j'ai pu créer un code qui me permet de copier des tableaux présents sur d'autres fichiers excel grâce au code suivant.
Private Sub Workbook_Open()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CAA As String 'déclare la variable CAA (Chemin d'Accès classeura)
Dim CSA As Workbook 'déclare la variable CSA (Classeur Source classeura)
Dim OSA As Worksheet 'déclare la variable OSA (Onglet Source classeura)
Dim CAB As String 'déclare la variable CAB (Chemin d'Accès classeurb)
Dim CSB As Workbook 'déclare la variable CSB (Classeur Source classeurb)
Dim OSB As Worksheet 'déclare la variable OSB (Onglet Source classeurb)
Sheets("Feuil1").Cells.Clear 'clear intégralement la feuille (texte, taille du texte, couleur, fusion des onglets)
Set CD = ThisWorkbook 'définit le classeur destination CD
CAA = "C:\Users\dao1\Desktop\" 'définit le chemin d'accès CAA classeura
Set OD = CD.Worksheets(1) 'définit l'onglet destination OD
'classeura
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set CSA = Workbooks("classeura.xlsm") 'définit le classeur source CSA (génère une erreur si ce classeur n'est pas ouvert)
If Err > 0 Then 'condition : si une erreur a été générée
Err.Clear 'supprime l'erreur
Set CSA = Workbooks.Open(CAA & "classeura.xlsm") 'définit le classeur source en l'ouvrant
End If 'fin de la condition
On Error GoTo 0 'fin de la gestion des erreurs
Set OSA = CSA.Worksheets("Feuil2") 'définit l'onglet source OSA
OSA.Range("F1:Q100").Copy OD.Range("B1") 'copie la plage éditée de l'onglet source et la colle dans B1 de l'onglet destination
CSA.Close False 'ferme le classeur source sans enregistrer
Set CD = ThisWorkbook 'définit le classeur destination CD
CAB = "C:\Users\dao1\Desktop\" 'définit le chemin d'accès CAB classeurb
Set OD = CD.Worksheets(1) 'définit l'onglet destination OD
'classeurb
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set CSB = Workbooks("classeurb.xlsm") 'définit le classeur source CSB (génère une erreur si ce classeur n'est pas ouvert)
If Err > 0 Then 'condition : si une erreur a été générée
Err.Clear 'supprime l'erreur
Set CSB = Workbooks.Open(CAB & "classeurb.xlsm") 'définit le classeur source en l'ouvrant
End If 'fin de la condition
On Error GoTo 0 'fin de la gestion des erreurs
Set OSB = CSB.Worksheets("Feuil2") 'définit l'onglet source OSB
OSB.Range("F1:Q100").Copy OD.Range("P1") 'copie la plage éditée de l'onglet source et la colle dans P1 de l'onglet destination
CSB.Close False 'ferme le classeur source sans enregistrer
End SubJe souhaite automatiser ce code avec un boucle qui m'éviterais de remplir manuellement tous les chemins d'accès des différents fichiers excel présents dans mes dossiers.
Le rangement de mes dossiers se fait comme suit.
Je veux récupérer dans mon fichier "Synthèse Fiche suivi AFF 25312.xlsm" tous les tableaux présents sur les fichiers excel "Fiche de suivi AFF 25312-numéro d'ouvrage".
Les variables sont :
- Le dossier principal affaire peut se trouver une fois sur mon bureau, une fois dans mes documents, etc ...
- Le numéro d'affaire qui peut changer
- Le nombre de sous dossier peut varier
- Des fichiers excel qui ne s'appelleront pas avec la même syntaxe peuvent se trouver dans les dossiers
Les constantes sont
- Les tableaux à copier se trouvent toujours sur les mêmes cellules
- Les fichiers excel concernés s'appellent toujours "Fiche de suivi AFF ...."
Merci d'avance pour votre aide et n'hésitez pas à me poser d'autres questions si des informations sont manquantes.
Bonjour,
Alors je trouve que ça fait beaucoup d'un coup... Il vaut mieux scinder les demandes.
Voici le code adapté de sorte qu'il dépende de paramètres variables (pour l'instant : le chemin complet du fichier source et l'adresse de destination) :
Sub Importer(NomSource$, AdresseDest$)
if dir(NomSource) = "" then
msgbox "Le fichier est introuvable !", vbcritical, "Sortie procédure"
exit sub
end if
on error goto Reprise
Set wsSource = Workbooks.open(NomSource).sheets("Feuil2")
Reprise:
if err.number = 9 then
msgbox "La feuille recherchée est introuvable", vbcritical, "Sortie procédure"
exit sub
elseif err.number = 1004 then
err.clear
on error goto Reprise
Set wsSource = Workbooks(NomSource).sheets("Feuil2")
end if
with thisworkbook
with .Sheets(1)
.Cells.Clear 'clear intégralement la feuille (texte, taille du texte, couleur, fusion des onglets)
wsSource.Range("F1:Q100").Copy .Range(AdresseDest) 'copie la plage éditée de l'onglet source et la colle dans B1 de l'onglet destination
Workbooks(NomSource).Close False 'ferme le classeur source sans enregistrer
end with
end with
End SubIl y a probablement des améliorations à faire sachant qu'ici, chaque import écrase le précédent. Donc il faudra probablement préciser le besoin pour modifier le coeur du code.
Donc, fini la procédure évènementielle (en tout cas pour le moment). On appelle cette macro à partir d'une autre qui reste à faire. J'ai juste mis la partie capitale où on exécute la macro Importer.
Sub Parcourir()
'code
if chemin like "*classeura*" then sAddDest = "B1" else sAddDest = "P1"
Call Importer(Chemin, sAddDest)
'code
end subCdlt,
Merci pour votre aide mais comme vous dites, faisons les choses dans l'ordre. Ca va bien trop vite pour moi.
Déjà je vais mettre à l'écrit ce que le code doit faire et nous reprendrons les étapes une à une.
1 - Récupération du dossier source dans lequel se situe le fichier excel "Synthèse"
2 - Pour chaque dossier contenu dans le dossier source, rentrer dans les dossiers les uns après les autres. (Possibilité de répéter cette opération plusieurs fois si dossiers dans dossiers dans dossiers ...)
Comment puis je réaliser ça ?
Je n'arrive pas à rentrer dans les dossiers contenus dans mon dossier source.
Pour faire ça, il faut utiliser une fonction ou procédure récursive (qui s'appelle elle-même) en passant par l'objet filesystemobject.
Mais je vois plutôt le problème à l'envers. Selon moi, il faut déjà bien déterminer les actions à réaliser avec la macro Importer. Il faut définir un cadre valable pour chaque fichier. Il faut donc bien réfléchir aux paramètres :
- noms ou index des feuilles sources ?
- Feuille de destination unique (est-ce bien la feuille n°1 ?) ?
- Plage de destination ("B1", "P1", autre ? dans quels cas ?) ?
- Faut-il bien coller les infos à la suite (pour l'instant on écrase) ?
- Faut-il coller uniquement les valeurs, les formules ou les cellules avec toutes leurs caractéristiques ?
Bonjour,
Désolé du retard, je ne travaillais pas. Pour répondre à vos questions :
- Noms ou index des feuilles sources ?
La feuille à copier est toujours la deuxième feuille du classeur.
- Feuille de destination unique (est-ce bien la feuille n°1 ?) ?
Oui tout en destination sur la feuille n°1.
- Plage de destination ("B1", "P1", autre ? dans quels cas ?) ?
Plage de destination B1 pour le premier copiage et ensuite laisser 5 lignes de vide entre chaque tableau qui sera copié. Les tableaux étant variables dans le temps, nous ferons un clean général de la feuille de destination.
- Faut-il bien coller les infos à la suite (pour l'instant on écrase) ?
On les colle à la suite les uns des autres mais la mise à jour de tous les fichiers sources se fait à chaque ouverture du fichier de destination, je mettrai ce code dans l'onglet : "Private Sub Workbook_Open()".
- Faut-il coller uniquement les valeurs, les formules ou les cellules avec toutes leurs caractéristiques ?
Il faut copier les valeurs et les couleurs des cellules.
Si vous pouviez m'aider dans un premier temps à gérer les boucles pour aller chercher les informations dans les fichiers excel se serait super, je pourrai ensuite travailler sur le reste du code mais cette partie là ne semble pas dans mes cordes.
Je vous remercie de passer du temps à m'aider.
Je viens de mettre un exemple de récursivité dans le fil "Faire un test d'une cellule sur plusieurs classeurs". Ton besoin est tout proche et le fso facile à adapter.
Bonjour à tous,
Voici un premier essai d'adaptation de la macro Importer. Il faut maintenant voir comment l'appeler
Sub Importer(NomSource$, entree&)
with Workbooks.open(NomSource)
if .sheets.count < 2 then exit sub else Set wsSource = .sheets(2)
end with
AdresseDest = "B" & (1 + (105 * entree - 105))
with thisworkbook
with .Sheets(1)
wsSource.Range("F1:Q100").Copy .Range(AdresseDest) 'copie la plage éditée de l'onglet source et la colle dans B1 de l'onglet destination
Workbooks(NomSource).Close False 'ferme le classeur source sans enregistrer
end with
end with
End SubJe mets le lien du sujet dont Optimix a parlé ici : https://forum.excel-pratique.com/excel/faire-un-test-d-une-cellule-sur-plusieurs-classeurs-153092
Je reviens avec un autre code bientôt...
Re,
Voici un premier essai avec un code complet :
'MODULE THISWORKBOOK
Private Sub Workbook_Open()
n = 0
Application.ScreenUpdating = False
With Me
.Sheets(1).Range("B:M").Clear
Parcourir .Path
.Sheets(1).Range("B:M").Value = .Sheets(1).Range("B:M").Value
End With
Application.ScreenUpdating = True
End Sub
'MODULE STANDARD
Public n&
Function Parcourir(spath$)
Set fso = CreateObject("Scripting.filesystemobject")
Set ofolder = fso.getfolder(spath)
For Each osubfolder In ofolder.subfolders
For Each ofile In osubfolder.Files
if ofile.path like "*.xls*" then
With Workbooks.Open(ofile.path)
If .Sheets.Count >= 2 Then
n = n + 1
.Sheets(2).Range("F1:Q100").Copy ThisWorkbook.sheets(1).Range("B" & (1 + (105 * n - 105)))
end if
.Close False 'ferme le classeur source sans enregistrer
End With
end if
Next ofile
Parcourir = Parcourir(osubfolder.Path)
Next osubfolder
End FunctionEdit : code modifié... A l'ouverture, on efface les colonnes B à M, on exécute la fonction récursive Parcourir qui parcourt chaque fichier de chaque dossier et ouvre le fichier en cours pour y copier/coller les cellules voulues.
Ce n'est pas testé forcément donc c'est à prendre comme un essai.
Cdlt,
Bonjour et merci pour le temps passé sur le fichier.
J'ai fait un premier test très basique. Il m'a fallu enlever ce bout de code qui me générait une erreur : Public n&. A quoi sert ce public ? Est-il vraiment indispensable ?
A première vue ce code répond à mes attentes. Il faut que je le peaufine pour que cela soit plus adapté à mes fichiers Excel mais c'est à moi de prendre le relais. Si j'ai de nouvelles questions et points que je n'arrive pas à résoudre, dois-je revenir sur ce topic ou dois-je en créer un nouveau pour vous solliciter ?
Le programme tourne une petite quinzaine de secondes alors que je n'ai que 3 fichiers à copier, est-ce inquiétant ou pas ?
Encore une fois, MERCI !
Bonjour,
Oui, le public est important. Il rend la variable n publique de manière à conserver sa valeur durant toute l'exécution car c'est la variable n qui permet de définir de façon variable où seront collées les copies.
En fait, les modules d'objets n'acceptent pas les variables publiques si je ne dis pas de bêtises.
Comme indiqué sur le code, il faut mettre public n& et la fonction qui suit dans un module standard.
Seule la macro open doit se trouver dans le module thisworkbook.
Si vous avez une question sur un détail du code ou si vous rencontrez une erreur, vous pouvez revenir ici. Si vous souhaitez l'adapter ou le modifier, je préfère que vous créiez un nouveau sujet.
C'est normal que l'exécution soit lente. Déjà, on parcourt tous les dossiers et fichiers du dossier parent mais surtout on ouvre des classeurs, on copie des cellules puis on ferme les classeurs. Ca prend un peu de temps mais sûrement moins qu'à la main.
Mais 15 secondes pour 3 fichiers, ça me semble un petit peu long quand même. Votre arborescence laissait suggérer qu'il y aurait au moins 9 fichiers (1 par sous-dossier).
D'accord je comprends.
Finalement cela met maintenant moins de 3 secondes. C'est parfait.
Avant de partir sur un nouveau topic, je voudrais régler un petit problème. Que le fichier ne copie que les cellules des fichiers excel commençant par Fiche de suivi. J'ai tenté de rajouter une boucle pour contrôler si le début du chemin du fichier excel coïncide avec un nom commençant par "Fiche de suivi" mais elle ne fonctionne pas ...
'MODULE STANDARD
Function Parcourir(spath$)
Set fso = CreateObject("Scripting.filesystemobject")
Set ofolder = fso.getfolder(spath)
For Each osubfolder In ofolder.subfolders
For Each ofile In osubfolder.Files
If ofile.Path Like "*.xls*" Then
If ofile.Path Like "osubfolder.Path & "Fiche de suivi*"" Then
With Workbooks.Open(ofile.Path)
If .Sheets.Count >= 2 Then
n = n + 1
.Sheets(2).Range("F1:Q100").Copy ThisWorkbook.Sheets(1).Range("B" & (1 + (105 * n - 105)))
End If
.Close False 'ferme le classeur source sans enregistrer
End With
Enf If
End If
Next ofile
Parcourir = Parcourir(osubfolder.Path)
Next osubfolder
End FunctionDe plus, lorsque je mets la partie en question sur WorkBook et l'autre sur la Feuil1, cela ne fonctionne pas. Je pense que je ne dois pas mettre les deux parties de code où il faut.
Il faut remettre la variable n en public sinon sinon je crains que les données n'écrasent les précédentes copies.
Voici un essai :
Public n& '<<<<< IMPORTANT
Function Parcourir(spath$)
Set fso = CreateObject("Scripting.filesystemobject")
Set ofolder = fso.getfolder(spath)
For Each osubfolder In ofolder.subfolders
For Each ofile In osubfolder.Files
If ofile.name like "Fiche de suivi*.xls*" Then
With Workbooks.Open(ofile.Path)
If .Sheets.Count >= 2 Then
n = n + 1
.Sheets(2).Range("F1:Q100").Copy ThisWorkbook.Sheets(1).Range("B" & (1 + (105 * n - 105)))
End If
.Close False 'ferme le classeur source sans enregistrer
End With
End If
Next ofile
Parcourir = Parcourir(osubfolder.Path)
Next osubfolder
End FunctionEdit : je viens d'éditer le code pour simplifier la condition.
Il faut aller dans Insertion/module et copier le code dans ce nouveau module. Les modules thisworkbook et Feuil1 sont des modules d'objets de l'application. La macro workbook_open, elle, doit bien rester dans le module thisworkbook puisque son exécution est conditionnée par l'évènement "open" de l'objet workbook.
Cdlt,
Sur ce coup là je ne comprends pas, je suis vraiment désolé ...
L'éditeur dispose d'un menu indépendant : on peut y voir fichier, edition, affichage, INSERTION, ....
Il faut cliquer sur Insertion puis ensuite, à l'apparition de la liste déroulante, cliquer sur Module.
Un nouveau module, nommé module1 apparaitra. Il faudra juste coller la partie Public n& et la fonction (public n devant se situer en tête de module).
La macro workbook_open doit rester où elle se trouve, c'est-à-dire dans le module thisworkbook.
Effectivement. Je vais aller me renseigner sur l'utilité de ces modules !
Je vous remercie vraiment, je n'aurais pas été capable de créer un code comme celui-là seul. J'espère que j'aurais de la chance d'avoir une aide utile sur mes prochaines questions comme vous me l'avez apportée !
Bonne soirée !
Ah enfin !
Je vous en prie ! C'est vrai que c'est assez complexe (en tout cas pour moi, c'est un petit exploit), ce n'est pas le genre de code qu'on fait tous les jours...
Je suis vraiment content que ça marche en tout cas.
Très bonne soirée à vous aussi et à bientôt peut-être sur le forum
Edit : et pour ces modules, c'est juste que les modules "thisworkbook", ... sont des modules de classe, des modules destinés à accueillir du code devant porter sur l'objet (ici workbook en l'occurrence). Ils permettent notamment de gérer les évènements (open par exemple) et ne sont pas fait pour de la saisie de code au kilomètre.
En général, il faut donc utiliser les modules standards et éventuellement exécuter les macros de ces modules standards dans des macros évènementielles.
Ha je vois. Félicitations en tout cas !
Et si je souhaite juste écrire le nom du fichier de référence avec de copier mes plages de données, comment puis-je faire ?
J'ai tenté ce code :
Workbooks.Name.Copy ThisWorkbook.Sheets(1).Range("B" & (DerniereLigne + 4)) mais ça ne marche pas...
Public n&
Function Parcourir(spath$)
Dim DerniereLignePlanExe As Integer
Dim DerniereLigneNdc As Integer
Dim DerniereLignePlanFab As Integer
Set fso = CreateObject("Scripting.filesystemobject")
Set ofolder = fso.getfolder(spath)
For Each osubfolder In ofolder.subfolders
For Each ofile In osubfolder.Files
If ofile.Path Like "*.xls*" And ofile.Name Like "Fiche de suivi*" Then
With Workbooks.Open(ofile.Path)
If .Sheets.Count >= 2 Then
Workbooks.Name.Copy ThisWorkbook.Sheets(1).Range("B" & (DerniereLigne + 4))
.Sheets(2).Range("O1:S100").Copy ThisWorkbook.Sheets(1).Range("B" & (DerniereLigne + 5))
.Sheets(2).Range("V1:Z100").Copy ThisWorkbook.Sheets(1).Range("I" & (DerniereLigne + 5))
.Sheets(2).Range("AG1:AH100").Copy ThisWorkbook.Sheets(1).Range("P" & (DerniereLigne + 5))
DerniereLignePlanExe = ThisWorkbook.Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
DerniereLigneNdc = ThisWorkbook.Sheets(1).Range("I" & Rows.Count).End(xlUp).Row
DerniereLignePlanFab = ThisWorkbook.Sheets(1).Range("P" & Rows.Count).End(xlUp).Row
If DerniereLignePlanExe >= DerniereLigneNdc And DerniereLignePlanExe >= DerniereLignePlanFab Then
DerniereLigne = DerniereLignePlanExe
Else
If DerniereLigneNdc >= DerniereLignePlanFab Then
DerniereLigne = DerniereLigneNdc
Else
DerniereLigne = DerniereLignePlanFab
End If
End If
End If
.Close False 'ferme le classeur source sans enregistrer
End With
End If
Next ofile
Parcourir = Parcourir(osubfolder.Path)
Next osubfolder
End FunctionDe ce que je vois, tu n'en veux vraiment pas de ma variable n
Comme je t'ai dit, si tu le modifies trop, je ne garantis rien d'autant que je t'avais bien fait remarquer que l'essentiel était de coder l'action à réaliser avant de coder la recherche de fichiers...
Function Parcourir(spath$)
Dim DerniereLignePlanExe As Integer
Dim DerniereLigneNdc As Integer
Dim DerniereLignePlanFab As Integer
Set fso = CreateObject("Scripting.filesystemobject")
Set ofolder = fso.getfolder(spath)
For Each osubfolder In ofolder.subfolders
For Each ofile In osubfolder.Files
If ofile.Path Like "*.xls*" And ofile.Name Like "Fiche de suivi*" Then
With Workbooks.Open(ofile.Path)
If .Sheets.Count >= 2 Then
ThisWorkbook.Sheets(1).Range("B" & (DerniereLigne + 4)).value = .name
.Sheets(2).Range("O1:S100").Copy ThisWorkbook.Sheets(1).Range("B" & (DerniereLigne + 5))
.Sheets(2).Range("V1:Z100").Copy ThisWorkbook.Sheets(1).Range("I" & (DerniereLigne + 5))
.Sheets(2).Range("AG1:AH100").Copy ThisWorkbook.Sheets(1).Range("P" & (DerniereLigne + 5))
DerniereLignePlanExe = ThisWorkbook.Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
DerniereLigneNdc = ThisWorkbook.Sheets(1).Range("I" & Rows.Count).End(xlUp).Row
DerniereLignePlanFab = ThisWorkbook.Sheets(1).Range("P" & Rows.Count).End(xlUp).Row
If DerniereLignePlanExe >= DerniereLigneNdc And DerniereLignePlanExe >= DerniereLignePlanFab Then
DerniereLigne = DerniereLignePlanExe
Else
If DerniereLigneNdc >= DerniereLignePlanFab Then
DerniereLigne = DerniereLigneNdc
Else
DerniereLigne = DerniereLignePlanFab
End If
End If
End If
.Close False 'ferme le classeur source sans enregistrer
End With
End If
Next ofile
Parcourir = Parcourir(osubfolder.Path)
Next osubfolder
End FunctionJ'ai l'impression que tu complexifies le code inutilement. Si je ne dis pas de bêtise, ta nouvelle ligne sera toujours un multiple de 105 (100 ligne de valeurs, 5 de vides) + 1 (ligne de reprise)... D'où mon petit n.
Après réflexion, je pense plutôt utiliser la valeur de la case D5 de la page 1 du fichier source sur la ligne précédent le tableau copié.
Cela fonctionne bien mais je souhaiterais dans le même temps fusionner les cellules de la colonne B à la colonne Q du fichier de réception. Cela fonctionne bien avec ce code quand je l'exécute dans un Private Sub mais ça ne marche pas quand je le place dans la boucle.
.Sheets(1).Range("D5").Copy ThisWorkbook.Sheets(1).Range("B" & (DerniereLigne + 4))
.Sheets(1).Range("B" & (DerniereLigne + 4), "Q" & (DerniereLigne + 4)).MergeCellsPS : Je ne viens de voir ton message que maintenant. Je suis joueur, j'aime bien essayé de plus en plus ^^
PS : En ajoutant la variable DerniereLigne, ça me permet de mettre les tableaux copiés les uns après les autres pour une impression future. Cela m'évite d'avoir 10 pages d'impression