Fusionner 180 fichiers excel à plusieurs feuil

Résolu/Fermé

LP - 28 mai 2014 à 17:34
gbinforme Messages postés 14946 Date d'inscription lundi 18 octobre 2004 Statut Contributeur Dernière intervention 24 juin 2020 - 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

A voir également:

Fusionner 180 fichiers excel à plusieurs feuil
Liste déroulante excel - Guide
Fusionner plusieurs fichiers excel - Guide
Renommer plusieurs fichiers - Guide
Aller à la ligne excel - Guide
Comment fusionner des pdf sans logiciel - Guide

3 réponses

Réponse 1 / 3

gbinforme Messages postés 14946 Date d'inscription lundi 18 octobre 2004 Statut Contributeur Dernière intervention 24 juin 2020 4 689
28 mai 2014 à 18:34

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 lundi 18 octobre 2004 Statut Contributeur Dernière intervention 24 juin 2020 4 689
29 mai 2014 à 17:52

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

LP
29 mai 2014 à 15:12

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.) ?

Discussions similaires

comment donner les droits sur fichier partage

Discussions similaires

Newsletters