Fusionner 180 fichiers excel à plusieurs feuil

Résolu

LP -
gbinforme Messages postés 14946 Date d'inscription Statut Contributeur Dernière intervention - 29 mai 2014 à 17:52

Bonjour,

Je reçois 10 fichiers excel tous du même format qui comportent chacun le même nombre d'onglet (soit 4). Je voudrais ''fusionner'' ses 10 fichiers en une seul qui comporterait 40 onglets (soit 10 fichiers x 4 onglets).

J'ai utilisé le macro suivant :

Sub consolide()
ChDir ActiveWorkbook.Path
Set classeurMaitre = ActiveWorkbook
sup
compteur = 1
nf = Dir("*.xls")
Do While nf <> ""
If nf <> classeurMaitre.Name Then
Workbooks.Open Filename:=nf
For k = 1 To Sheets.Count
Sheets(k).Copy After:=classeurMaitre.Sheets(classeurMaitre.Sheets.Count)
classeurMaitre.Sheets(classeurMaitre.Sheets.Count).Name = "Mapage" & compteur
compteur = compteur + 1
Next k
Workbooks(nf).Close False
End If
nf = Dir
Loop
End Sub

Sub sup()
Application.DisplayAlerts = False
If Sheets.Count > 1 Then
Sheets("Accueil").Move before:=Sheets(1)
Sheets(2).Select
For i = 2 To Sheets.Count
ActiveSheet.Delete
Next i
End If
End Sub

Or, ce macro ne semble utiliser que le 1er onglet des fichiers (en plus de créer 5 copies non désiré d'onglets).

Peut-on modifier ce macro pour qu'il réponde à mes besoins, y a-t-il d'autres solutions ?

Merci !!

LP

Afficher la suite

A voir également:

Fusionner 180 fichiers excel à plusieurs feuil
Liste déroulante excel - Guide
Formule moyenne excel plusieurs colonnes - Guide
Fusionner plusieurs fichiers excel - Guide
Renommer plusieurs fichiers en même temps - Guide
Word et excel gratuit - Guide

3 réponses

Réponse 1 / 3

gbinforme Messages postés 14946 Date d'inscription Statut Contributeur Dernière intervention 4 724

Bonjour,

Voici la correction testée que je te propose :

Option Explicit
Sub consolide()
Dim rep As String, classeurMaitre As Workbook, wk As Workbook
Dim compteur As Integer, k As Integer, nf As String
    Call sup
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    rep = ActiveWorkbook.Path & "\"
    Set classeurMaitre = ActiveWorkbook
    compteur = 1
    nf = Dir(rep & "*.xls")
    While nf <> ""
        If nf <> classeurMaitre.Name Then
            Workbooks.Open Filename:=rep & nf
            Set wk = ActiveWorkbook
            For k = 1 To Sheets.Count
                classeurMaitre.Sheets.Add After:=classeurMaitre.Sheets(classeurMaitre.Sheets.Count)
                classeurMaitre.Sheets(classeurMaitre.Sheets.Count).Name = "Mapage" & compteur
                wk.Sheets(k).UsedRange.Copy Destination:=classeurMaitre.Sheets("Mapage" & compteur).[A1]
                compteur = compteur + 1
            Next k
            Workbooks(nf).Close False
        End If
        nf = Dir
    Wend
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub
Sub sup()
Dim i As Integer
Application.DisplayAlerts = False
    For i = Sheets.Count To 1 Step -1
        If Sheets(i).Name <> "Accueil" Then
            Sheets(i).Delete
        End If
    Next i
Application.DisplayAlerts = True
End Sub

--
Toujours zen
La perfection est atteinte, non pas lorsqu'il n'y a plus rien à ajouter, mais lorsqu'il n'y a plus rien à retirer. Antoine de Saint-Exupéry

Réponse 2 / 3

gbinforme Messages postés 14946 Date d'inscription Statut Contributeur Dernière intervention 4 724

Bonjour,

Tu remplaces ceci :

                wk.Sheets(k).UsedRange.Copy Destination:=classeurMaitre.Sheets("Mapage" & compteur).[A1]

par

                wk.Sheets(k).UsedRange.Copy
                classeurMaitre.Sheets("Mapage" & compteur).[A1].PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False

et cela devrait le faire.

Réponse 3 / 3

Malade !!! Ça fonctionne très bien, mais est-il possible qu'en plus de fusionner les fichiers, ils conservent leurs mise en page !? (largeur de colonne, etc.) ?

Votre réponse