Fusionner feuille de classeurs dans fichier unique
Bonjour à tous !
Je sais que le sujet a été évoqué maintes fois et avant de faire appel à vous, j'ai pris mon temps pour éviter un énième post mais je n'ai pas réussi à trouver la réponse que je cherchais.
Je vais essayer d'être aussi précis que possible, si je ne le suis pas, veuillez m'en excuser, je rectifierai le tir aussi vite que possible.
Mon problème : J'ai plusieurs dizaines de classeurs regroupés dans un dossier (et d'autres vont venir s'y rajouter). J'aimerai que l'ensemble des feuilles n°2 de ces classeurs (et uniquement celui-là) alimentent un fichier unique (comme une base de données) sachant que ces fameux feuillets ont exactement la même structure, seules les données changent.
Je tiens à préciser que dans les feuilles (la numéro 2 donc) que je dois "copier" dans ce fichier unique il y a des cellules dont le contenu est déterminé par des menus déroulants (attention certaines cellules sont alimentées par l'onglet n°1)
Les données concernées sont surtout des dates et quelques cellules avec des commentaires (pas de formules de calcul) mais afin d'éviter que certaines saisies soient freestyle, je souhaiterai verrouiller certaines cellules.
Afin que vous puissiez vous rendre compte du rendu que je souhaite, vous trouverez trois pièces jointes (deux exemples et le résultat escompté)
D'avance je vous remercie beaucoup du temps que vous passerez à m'aider. Je reste à l'affût pour répondre à vos questions au besoin.
Tiouinch.
PS : je fonctionne sous EXCEL 2007 mais tout doit être compatible en 97-2003.
Bonsoir,
une proposition,
Sub fusionclasseur()
set wbf=ThisWorkbook ' wbf reférence le classeur maitre
Set wsc = wbf.Worksheets.Add ' on ajoute une feuille dans le classeur maitre
wsc.Name = "Résultat fusion" ' on nomme la feuille " résultat fusion"
'-------------------------------
' on demande le nom du répertoire qui contient les fichiers à fusionner via dialogue windows
' résultat dans chemin
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Sélectionner le répertoire contenant les fichiers à fusionner"
.Filters.Clear
.AllowMultiSelect = False
If .Show = -1 Then ' si un répertoire sélectionné
chemin = .SelectedItems(1) & "\" ' on le met dans chemin
Else
Exit Sub 'pas de répertoire sélectionné, on arrête
End If
End With
'---------------------------------
masque = InputBox("introduire le filtre de sélection des classeurs (défaut *.xls*)") ' masque est le filtre des fichiers à sélectionner
wsn = InputBox("Nom de la feuille à copier de chaque classeur (défaut première feuille trouvée)") ' wsn nom de la feuille à copier de chaque classeur à fusionner
If masque = "" Then masque = "*.xls*" ' si masque est vide on attribue le filtre par défaut
f = Dir(chemin & masque) ' f= nom du premier fichier correspondant au critère
ctrf = 0 ' compteur de classeurs fusionnés
pli = 1 'première ligne sur résultat fusion
While f <> "" ' tant qu'il y a des fichiers(classeurs)) à fusionner
ctrf = ctrf + 1 '
Set wbi = Workbooks.Open(chemin & f) ' on ouvre le classeur
If wbi.Name <> wbf.Name Then ' si classeur différent du classeur maitre
If wsn = "" Then Set wsi = wbi.Worksheets(1) Else Set wsi = wbi.Worksheets(wsn) ' on sélectionne la feuille à fusionner =wsi
dli = wsi.Range("A" & Rows.Count).End(xlUp).Row ' dli dernière ligne sur wsi
If dli > 1 Then
If ctrf = 1 Then pl = 1 Else pl = 2 ' si premier classeur à fusionner, il faut copier l'entête
wsi.Rows(pl & ":" & dli).Copy
wsc.Range("a" & pli).pastespecial paste:=xlpastevalues 'on copie les lignes du classeur à fusionner dans la feuille résultat de fusion
pli = pli + dli + 1 - pl ' on ajuste le nombre de lignes de résultat fusion
End If
End If
wbi.Close 'on ferme le classeur
f = Dir() 'on passe au classeur suivant
Wend
End Sub
Bonjour h2so4,
Je te remercie pour ton aide, surtout à l'heure à laquelle je vois que tu as écris ces lignes.
J'ai repris ce que tu m'as indiqué en renseignant les lignes en rouge, ce qui me donne ça :
Sub fusionclasseur()
Set wbf = ThisWorkbook ' wbf reférence le classeur maitre
Set wsc = wbf.Worksheets.Add ' on ajoute une feuille dans le classeur maitre
wsc.Name = "Résultat Fusion"
'-------------------------------
' on demande le nom du répertoire qui contient les fichiers à fusionner via dialogue windows
' résultat dans chemin
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Y:\InterServices\BDE-AssistSociale\STAGIAIRE2014\TEST Excel agrégé\Test Récap"
.Filters.Clear
.AllowMultiSelect = False
If .Show = -1 Then ' si un répertoire sélectionné
chemin = .SelectedItems(1) & "\" ' on le met dans chemin
Else
Exit Sub 'pas de répertoire sélectionné, on arrête
End If
End With
'---------------------------------
masque = InputBox("*.xls*") ' masque est le filtre des fichiers à sélectionner
wsn = InputBox("Tableau de Suivi") ' wsn nom de la feuille à copier de chaque classeur à fusionner
If masque = "" Then masque = "*.xls*" ' si masque est vide on attribue le filtre par défaut
f = Dir(chemin & masque) ' f= nom du premier fichier correspondant au critère
ctrf = 0 ' compteur de classeurs fusionnés
pli = 1 'première ligne sur résultat fusion
While f <> "" ' tant qu'il y a des fichiers(classeurs)) à fusionner
ctrf = ctrf + 1 '
Set wbi = Workbooks.Open(chemin & f) ' on ouvre le classeur
If wbi.Name <> wbf.Name Then ' si classeur différent du classeur maitre
If wsn = "" Then Set wsi = wbi.Worksheets(1) Else Set wsi = wbi.Worksheets(wsn) ' on sélectionne la feuille à fusionner =wsi
dli = wsi.Range("A" & Rows.Count).End(xlUp).Row ' dli dernière ligne sur wsi
If dli > 1 Then
If ctrf = 1 Then pl = 1 Else pl = 2 ' si premier classeur à fusionner, il faut copier l'entête
wsi.Rows(pl & ":" & dli).Copy
wsc.Range("a" & pli).PasteSpecial Paste:=xlPasteValues 'on copie les lignes du classeur à fusionner dans la feuille résultat de fusion
pli = pli + dli + 1 - pl ' on ajuste le nombre de lignes de résultat fusion
End If
End If
wbi.Close 'on ferme le classeur
f = Dir() 'on passe au classeur suivant
Wend
End Sub
Je lance la macro et là soucis, une fois la fenêtre de dialogue ouverte me demandant le répertoire concerné (sachant que c'est le même) il ne semble pas "voir" les fichiers excel. (problème de saisie du format excel?) puis ensuite il me dit que le fichier Récap(celui où toutes les lignes doivent être copiées) est déjà ouvert, si vous l'ouvrez à nouveau vous perdrez vos données blablabla.
Et bien-sûr rien ne se passe.
Je te remercie encore de ton aide mais je crois que je vais encore avoir besoin de toi. Bonne journée à toi.
Je viens de réessayer en mettant cette fois-çi le nom des fichiers manuellement quand il me le demande dans la boîte de dialogue (et aussi au passage, j'ai indiqué que c'est la feuille numéro 2 dans la ligne de code :
If wsn = "" Then Set wsi = wbi.Worksheets(2) Else Set wsi = wbi.Worksheets(wsn)
Mon souhait c'est que :
1) Je n'ai pas de boîte de dialogue pour me demander dans quel dossier, quels fichiers car tout sera au même endroit (dans le même dossier)
2) Je n'ai pas à les rentrer, il les détecte automatiquement (car je vais en avoir plusieurs dizaines)
3) La ligne qui doit être copiée et rajouter au fichier général soit uniquement la 4ème (et pas la 3 et la 4)
Je t'ai mis en pièce jointe ce que ça donne (l'espace entre les deux saisies reportées n'est pas nécessaire) Du coup c'est presque ça mais pas encore tout à fait.
J'espère que ces précisions t'aideront. De mon côté j'essaie de creuser en farfouillant à droite à et gauche. Je te remercie encore de ton aide. Bon courage pour ta journée.
Bon c'est la dernière fois que je t'écris parce que je vais sans doute te compliquer la tâche plus qu'autre chose, je n'avais pas vu le changement de couleur à compléter, ce que je viens de faire, cela concernait la ligne 4 que je souhaitais copier.
dli = wsi.Range("4" & Rows.Count).End(xlUp).Row
wsc.Range("4" & pli).PasteSpecial Paste:=xlPasteValues
Cependant avec ces nouvelles valeurs, plus rien ne se passe du tout, même en rajoutant comme précédemment le nom des fichiers à la main...
Au plaisir de te lire. Bonne journée.
Bonjour,
voici le code générique adapté pour ton besoin spécifique.
Sub fusionclasseur()
Set wbf = ThisWorkbook ' wbf reférence le classeur maitre
Set wsc = Worksheets("Classeur Général") ' feuille doit exister
pli = wsc.Cells(Rows.Count, 1).End(xlUp).Row + 1
chemin = "Y:\InterServices\BDE-AssistSociale\STAGIAIRE2014\TEST Excel agrégé\Test Récap\"
masque = "*.xls*"
f = Dir(chemin & masque) ' f= nom du premier fichier correspondant au critère
While f <> "" ' tant qu'il y a des fichiers(classeurs)) à fusionner
Set wbi = Workbooks.Open(chemin & f) ' on ouvre le classeur
If wbi.Name <> wbf.Name Then ' si classeur différent du classeur maitre
Set wsi = wbi.Worksheets(2)
dli = wsi.Range("A" & Rows.Count).End(xlUp).Row ' dli dernière ligne sur wsi
If dli > 3 Then
pl = 4
wsi.Rows(pl & ":" & dli).Copy
wsc.Range("a" & pli).PasteSpecial Paste:=xlPasteValues 'on copie les lignes du classeur à fusionner dans la feuille résultat de fusion
pli = pli + dli + 1 - pl ' on ajuste le nombre de lignes de résultat fusion
End If
End If
wbi.Close 'on ferme le classeur
f = Dir() 'on passe au classeur suivant
Wend
End Sub
Bonjour h2so4 !
Merci beaucoup de m'avoir répondu aussi vite.
Alors ça fonctionne PRESQUE ! lol. En effet, la macro ouvre systématiquement les classeurs concernés et il me faut confirmer que je veux bien copier les données (pas dérangeant quand je n'ai que deux classeurs, mais vu que j'en ai plusieurs dizaines ! lol)
Enfin, il me demande si je veux rouvrir le fichier maître. Et après mon choix de réponse, il m'indique Erreur d'exécution '1004' La méthode 'Open' de l'objet 'Workbooks' a échoué.
Il ne faut vraiment pas grand chose pour que ça fonctionne, on y est presque !
Je te remercie grandement de ton aide en tout cas.
bonjour,
Sub fusionclasseur()
Set wbf = ThisWorkbook ' wbf reférence le classeur maitre
Set wsc = Worksheets("Classeur Général") ' feuille doit exister
pli = wsc.Cells(Rows.Count, 1).End(xlUp).Row + 1
chemin = "Y:\InterServices\BDE-AssistSociale\STAGIAIRE2014\TEST Excel agrégé\Test Récap\"
masque = "*.xls*"
f = Dir(chemin & masque) ' f= nom du premier fichier correspondant au critère
Application.DisplayAlerts = False
While f <> "" ' tant qu'il y a des fichiers(classeurs)) à fusionner
If wbf.Name <> f Then
Set wbi = Workbooks.Open(chemin & f) ' on ouvre le classeur
' si classeur différent du classeur maitre
Set wsi = wbi.Worksheets(2)
dli = wsi.Range("A" & Rows.Count).End(xlUp).Row ' dli dernière ligne sur wsi
If dli > 3 Then
pl = 4
wsi.Rows(pl & ":" & dli).Copy
wsc.Range("a" & pli).PasteSpecial Paste:=xlPasteValues 'on copie les lignes du classeur à fusionner dans la feuille résultat de fusion
pli = pli + dli + 1 - pl ' on ajuste le nombre de lignes de résultat fusion
End If
wbi.Saved = True
wbi.Close
End If 'on ferme le classeur
f = Dir() 'on passe au classeur suivant
Wend
Application.DisplayAlerts = True
End Sub
Que te dire à part un grand merci ! Tu as l'air de faire cela même en dormant, c'est cool !
Merci beaucoup, ça va vraiment m'être d'une grande aide. Je vais faire le test avec une dizaine de fichiers à compléter et au besoin je reviendrai vers toi mais là franchement c'est juste top (même si je ne comprends qu'un tiers de ton code).
Merci de ton aide h2so4.
Bonjour à tous et re à h2so4 sans qui je continuerai de m'arracher les cheveux.
Tout fonctionne impeccablement, cependant, il est fort possible que ce dossier soit consulté ultérieurement par plusieurs personnes.
Existe-t-il un moyen pour que le dossier ne recopie pas les lignes déjà présentes dans le document ?
Je m'explique : Le document "Récap" est vierge. Je lance la macro, il me cumule toutes mes infos de tous mes dossiers à l'heure H.
Je souhaiterai que si je relance la macro à H+1 (entre temps d'autres dossiers seront probablement arrivés) il ne recopie pas l'ensemble de ce qu'il a précédemment copié mais uniquement les nouveaux.
Pour l'instant, il "cumule" ceux agrégés à l'heure H, et ceux à l'heure H+1 (les anciens ET les nouveaux)
Merci de votre aide et je vous souhaite une excellente journée.
Tiouinch.
Bonjour,
qu'est-ce qui permet à coup sûr, de vérifier qu'un dossier est déjà pris en compte ou non ? le nom + le prénom ?
Re H2so4 !
J'ai bien envie de te répondre que serait cool mais je me demande si en cas de doublon de nom et prénom, je ne vais pas avoir de problème de classeur non pris en compte !
NOM + Prénom est un début cependant, dans le fichier mis à disposition précédemment, je pense que 2 voire 3 autres paramètres serait pas mal pour se border contre ça.
Exemple : Visite Médicale, Service et Remise Liste des docs Simu
Si deux personnes ont ces 5 paramètres en commun, c'est pas de bol tout de même.
Je te remercie encore de ton aide et de ton temps.
Re bonjour,
et le nom du fichier est-il unique ? est-il pensable de rajouter cette donnée dans le fichier recap lorsqu'on copie les données.
il suffirait alors de vérifier si le nom du fichier se trouve déjà dans recap pour ne plus le prendre en compte.
Oui un dossier sera créé pour chaque nouveau client (et sera donc unique) sauf le fichier Récap qui lui restera toujours le même.
Effectivement il serait peut-être plus judicieux de vérifier le contenant plutôt que le contenu !
Bonjour,
le code est adapté pour éviter de traiter les fichiers déjà pris en compte.
Cela suppose que tu ajoutes une colonne nommée "Fichier", dans ton onglet "Classeur Général" de ton Classeur Récap.
Sub fusionclasseur()
Set wbf = ThisWorkbook ' wbf reférence le classeur maitre
Set wsc = Worksheets("Classeur Général") ' feuille doit exister
Set re = wsc.Rows(3).Find("Fichier", lookat:=xlWhole)
If re Is Nothing Then MsgBox "colonne 'Fichier' non trouvée dans 'Classeur Général' en ligne 3": Exit Sub
colfichier = re.Column
pli = wsc.Cells(Rows.Count, 1).End(xlUp).Row + 1
chemin = "Y:\InterServices\BDE-AssistSociale\STAGIAIRE2014\TEST Excel agrégé\Test Récap\"
masque = "*.xls*"
f = Dir(chemin & masque) ' f= nom du premier fichier correspondant au critère
Application.DisplayAlerts = False
While f <> "" ' tant qu'il y a des fichiers(classeurs)) à fusionner
If wbf.Name <> f Then
Set re = wsc.Range(wsc.Cells(4, colfichier), wsc.Cells(pli, colfichier)).Find(f, lookat:=xlWhole)
If re Is Nothing Then
Set wbi = Workbooks.Open(chemin & f) ' on ouvre le classeur
' si classeur différent du classeur maitre
Set wsi = wbi.Worksheets(2)
dli = wsi.Range("A" & Rows.Count).End(xlUp).Row ' dli dernière ligne sur wsi
If dli > 3 Then
pl = 4
wsi.Rows(pl & ":" & dli).Copy
wsc.Range("a" & pli).PasteSpecial Paste:=xlPasteValues 'on copie les lignes du classeur à fusionner dans la feuille résultat de fusion
wsc.Range(wsc.Cells(pli, colfichier), wsc.Cells(pli + dli - pl, colfichier)) = f 'on ajoute le nom du fichier dans la dernière colonne
pli = pli + dli + 1 - pl ' on ajuste le nombre de lignes de résultat fusion
End If
wbi.Saved = True
wbi.Close 'on ferme le classeur
End If
End If
f = Dir() 'on passe au classeur suivant
Wend
Application.DisplayAlerts = True
End Sub
Re !
J'ai rajouté une colonne Fichier que j'ai inséré en A1 et en A3 j'ai mis le mot fichier.
Cela fonctionne par contre petit bémol, le nom des fichiers "écrase" le nom de mes clients et tous les résultats sont décalés.
J'ai fais un autre essai sans rajouter de colonne mais en laissant le mot Fichier en A3.
Cela fonctionne aussi mais pareil, le nom de mes clients est écrasé par le nom du fichier.
Est-ce que cette colonne pourrait être dans la colonne X(comme ça pas besoin besoin de ton décaler d'un cran)
A moins que tu aies une astuce pour l'insérer en colonne A ?
Dis moi si je ne suis pas assez clair, je pourrai t'envoyer des copies d'écran.
Re !
Je te prie de bien vouloir m'excuser H2so4, j'ai changé sans t'en avertir mon fichier récap, du coup effectivement, ça ne correspondait plus (la fameuse commande où le mot fichier doit apparaître en ligne 3 notamment)
Bref j'ai rectifié en remplaçant la ligne 3 par la ligne 1 et ça fonctionne bien (en tout cas lors du premier lancement de macro)
Par contre j'ai fais un test. Il me les copie tous (normal pour un premier lancement) J'en supprime la moitié. Je relance, il me les copie encore toutes...
J'ai essayé d'enregistrer le fichier avec la moitié des refs, fermer le classeur, le rouvrir et de le relancer mais pareil, il me les copie à la suite des premiers enregistrés et du coup doublon...
Précision : quand je l’exécute deux fois de suite, il me copie tout la première fois, et la deuxième il me copie que les deux premiers mais pas le reste.
Précision n°2ce sont mes changements à la noix qui fichent le bazar dans ton travail.
Si je reprends la mise en forme du dossier Récap initiale sans toucher à rien, si ce n'est à faire ce que tu m'as dis, ça fonctionne impeccablement. Même en supprimant plusieurs lignes et en relançant la macro il fait exactement ce que je voulais.
Je suis vraiment désolé, je t'ai donné de la lecture pour rien. ça m'apprendra.
Je te remercie beaucoup pour ton aide, tu es un as !
Bonjour,
ajoute la colonne "Fichier" comme dernière colonne et non comme première. j'aurais dû te le préciser.
Oui c'est ce que j'ai fais ne t'inquiètes pas ! C'est super, le résultat est propre et nickel. Merci beaucoup. Je te souhaite une bonne fin de journée !