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 !