Réunir plusieurs classeur en un seul

[fouggy]

Slt à tout le forum,

Je souhaiterais disposer d'une macro qui réunie tous les onglets de tous les classeurs contenus dans un même répertoire dans un seul et unique classeur.

Le top finesse serait que seuls soient copiés les onglets ayant un nom (quel qu'il soit) ne commençant pas par "feuille..." évitant ainsi la copie inutile d'onglets existants par défaut.

Quelques macros sont proposées en réponses sur divers forums mais aucune ne marche.

Avec plus de 200000 onglets, répartis dans plusieurs classeurs, vous comprendrez l'ampleur de la tâche et les raisons qui m'amènent à faire appel à votre aide.

Si je souhaite réunir l'ensemble de ces onglets c'est que je dois appliquer à chaque classeur une 10ne de macros d'où l'intérêt de réunir l'ensemble de ces onglet afin de ne pas avoir à appliquer la 10ne de macro à chaque classeur qui contient à peu près 1000 onglets. Et 200000 onglets divisés par 1000 donne une idée du nombre de classeurs à traiter, lol

En rédigeant ce post d'autres questions me viennent :
Combien d'onglets peut accueillir un seul et même classeur sur excel 2010 ?
D'autres part, et pour info vu ce que je cherche à faire, est-il possible d'appliquer une macro à tous les classeurs fermés d'un même répertoire, ce qui reviendrait au même.

Merci d'avance pour vos réponses.

 

[camarchepas]

Re : Réunir plusieurs classeur en un seul

Bonjour ,

un premier jet,
Ne remonte que les fichiers Xls et Xlsx (Modifiable)
evince les onglets commençant par Feuil. (Modifiable)
Régler également le chemin : Pour le moment "c:\appli_Excel"
Par contre pas prévu et pas testé si 2 onglets portaient le même nom (Que faudrait-il faire ?)

Sub Copie()
Dim Classeur As String
Dim Chemin As String
Dim Onglet As Worksheet
Dim LigneFin As Long, LigneFinACopier As Long
'Exemple : Chemin à adapter
Chemin = "c:\appli_Excel\"
'Si uniquement des fichiers xsl ou xslx , modifier l'extension en conséquence
Classeur = Dir(Chemin & "*.xlsx") ' ici le * aprés le xlsx n'est donc plus nécessaire , j'ai enlevé
Do
If Classeur <> "" Then
Application.EnableEvents = False
Workbooks.Open Chemin & Classeur
For Each Onglet In Workbooks(Classeur).Worksheets
'Trouve une cellule qui est systématiquement renseigné pour l'exemple ici C13 à modifier
     If Left(Onglet.Name, 5) <> "Feuil" Then
     
      'Ajout de la création de l'onglet
      ThisWorkbook.Worksheets.Add
      ThisWorkbook.ActiveSheet.Name = Onglet.Name
      LigneFinACopier = Onglet.Range("A" & Rows.Count).End(xlUp).Row
       Onglet.Range("A1:H" & LigneFinACopier).Copy Destination:=ThisWorkbook.Sheets(Onglet.Name).Range("A1")
     Exit For
     End If
Next
Workbooks(Classeur).Close False
Application.EnableEvents = True
End If
Classeur = Dir
Loop Until Classeur = ""
End Sub

 

[fouggy]

Re : Réunir plusieurs classeur en un seul

Slt camarchepas et merci pour ta réponse mais... Ca marche pas, lol.

Il m'envoi le message suivant :
Erreur d'exécution "5"
Argument ou appel de procédure incorrect et me surligne en jaune l'avant dernière ligne avant End Sub :
Classeur = Dir

Peux-tu rectifier ?

Merci pour ton aide

 

[camarchepas]

Re : Réunir plusieurs classeur en un seul

Re ,

Bon , moi j'ai testé et cela fonctionne , donc ce sont surement les paramètres qui ne sont pas identiques

Les classeurs à ouvrir sont dans quel dossier , il faut modifier l'affectation de Chemin

pourtant dans les commentaires du code j'ai bien précisé :
'Exemple : Chemin à adapter
Chemin = "c:\appli_Excel\"

pour le coup , j'ai juste ajouté un test pour ne pas avoir l'erreur et pour guider l'utilisateur

^ Edit : Oups comme c'est une fonction que j'ai écrit pour autre chose et adapté , j'ai laissé un ancien commentaire
'Trouve une cellule qui est systématiquement renseigné pour l'exemple ici C13 à modifier
qui n'a en fait aucune signification , puisque maintenant l'on ne regarde pas si une cellule est utilisée , l'on filtre selon le début du nom de l'onglet
donc rectifié

Sub Copie()
 Dim Classeur As String
 Dim Chemin As String
 Dim Onglet As Worksheet
 Dim LigneFin As Long, LigneFinACopier As Long
 'Exemple : Chemin à adapter
 Chemin = "c:\appli_Excel\"
 'Si uniquement des fichiers xsl ou xslx , modifier l'extension en conséquence
 Classeur = Dir(Chemin & "*.xlsx") ' ici le * aprés le xlsx n'est donc plus nécessaire , j'ai enlevé
 If Classeur = "" Then MsgBox " Le répertoire " & Chemin & " est vide ou inexistant": Exit Sub
 Do
 If Classeur <> "" Then
 Application.EnableEvents = False
 Workbooks.Open Chemin & Classeur
 For Each Onglet In Workbooks(Classeur).Worksheets
  'Filtre par rapport au début du nom de la feuille
      If Left(Onglet.Name, 5) <> "Feuil" Then
      
       'Ajout de la création de l'onglet
       ThisWorkbook.Worksheets.Add
       ThisWorkbook.ActiveSheet.Name = Onglet.Name
       LigneFinACopier = Onglet.Range("A" & Rows.Count).End(xlUp).Row
        Onglet.Range("A1:H" & LigneFinACopier).Copy Destination:=ThisWorkbook.Sheets(Onglet.Name).Range("A1")
      Exit For
      End If
 Next
 Workbooks(Classeur).Close False
 Application.EnableEvents = True
 End If
 Classeur = Dir
 Loop Until Classeur = ""
 End Sub

 

[camarchepas]

Re : Réunir plusieurs classeur en un seul

Allez , voici donc le code rectifié ,

Jamais simple de tester sans environnement.

grace à mon béta testeur et son environnement de test , j'ai enfin mis le doigt sur le problème

Sub FusionFichiers()

 Dim Classeur As String
 Dim Chemin As String
 Dim Onglet As Worksheet
 Dim LigneFin As Long, LigneFinACopier As Long
 'Exemple : Chemin à adapter
 Chemin = "C:\Test_Fusion_Classeurs\"
 'Si uniquement des fichiers xls ou xslx , modifier l'extension en conséquence
 Classeur = Dir(Chemin & "*.xls") 
 If Classeur = "" Then MsgBox " Le répertoire " & Chemin & " est vide ou inexistant": Exit Sub
 Do
 If Classeur <> "" Then
 Application.EnableEvents = False
 Workbooks.Open Chemin & Classeur
 For Each Onglet In Workbooks(Classeur).Worksheets
 'Ne traite que les onglets dont le nom ne commence pas par Feuil
      If Left(Onglet.Name, 5) <> "Feuil" Then
      
       'Ajout de la création de l'onglet
       ThisWorkbook.Worksheets.Add
       ThisWorkbook.ActiveSheet.Name = Onglet.Name
       LigneFinACopier = Onglet.Range("A" & Rows.Count).End(xlUp).Row
        Onglet.Range("A1:H" & LigneFinACopier).Copy Destination:=ThisWorkbook.Sheets(Onglet.Name).Range("A1")
      End If
 Next
 Workbooks(Classeur).Close False
 Application.EnableEvents = True
 End If
 Classeur = Dir
 Loop Until Classeur = ""
 End Sub

 

[fouggy]

Re : Réunir plusieurs classeur en un seul

Yoooooooo,

Mille merci à toi, ça fonctionne au top...

 

[camarchepas]

Re : Réunir plusieurs classeur en un seul

Bonjour ,

C'est super ,

et un grand plaisir pour moi.

a trés bientôt