Fusion de fichiers excel

seb8791

XLDnaute Nouveau
Bonjour à tous,

J'ai déjà vu des sujets à ce sujet mais aucune macro ne semble fonctionner ou en tout cas ne fonctionne pas pour mon cas qui me semblait simple.

Je possède 90 fichiers (xlsx) qui ont parfois plusieurs feuilles.

J'aimerais tous les combiner dans un seul fichier excel nouveau.

Par ailleurs, j'aimerais une autre macro pour regrouper sur une meme feuille toutes les données Excel d'un classeur à plusieurs feuilles.

Quelqu'un aurait il ces deux macro magique ?

Merci par avance,
 

Lone-wolf

XLDnaute Barbatruc
Bonjour seb, le Forum :) :)

Bienvenue sur XLD. Quelle version d'Excel utilises-tu?

J'aimerais tous les combiner dans un seul fichier excel nouveau. Ont-ils tous la même structure? Si ce n'est pas le cas, ton classeur va être du charabia; quelle est la dernière colonne remplie dans ces classeurs???. Mieux vaut utiliser que la 2ème solution.
 
Dernière édition:

Guy_M

XLDnaute Occasionnel
Bonjour seb8791,

Peut-être avec un peu de retard, j'avais écrit une macro qui rassemble toutes les données d'un classeur dans la première feuille, à tester pour savoir si cela vous convient.

VB:
'Cette procédure regroupe toute les feuilles du classeur actif dans la première
Sub FeuillesRegrouper()

Dim Reponse As VbMsgBoxResult
Dim Feuille As Worksheet
Dim PremiereFeuille As Worksheet

Reponse = MsgBox("Souhaitez vous regrouper toute les feuilles du classeur dans la première ?", vbQuestion + vbYesNo, "Continuer ?")
If Reponse <> vbYes Then Exit Sub

Application.ScreenUpdating = False

Set PremiereFeuille = ActiveWorkbook.Sheets(1)

If PremiereFeuille.Type <> xlWorksheet Then
    MsgBox "La première Feuille doit être une feuille de calcul.", vbCritical
End If

'Réinitialisation du usedrange de la première feuille
Set Feuille = ActiveSheet 'Conservation de la feuille active
PremiereFeuille.Activate
ActiveSheet.UsedRange
Feuille.Activate 'Restitution de la feuille active

For Each Feuille In ActiveWorkbook.Worksheets 'selectionne toutes les feuilles
    If Feuille.Name <> PremiereFeuille.Name Then 'on copie le contenu de toutes les feuilles sauf la première
        Feuille.UsedRange.Copy
        PremiereFeuille.Paste Destination:=PremiereFeuille.Range("A" & PremiereFeuille.UsedRange.Rows.Count + 1)
    End If
Next

Application.ScreenUpdating = True

End Sub
A bientôt
Guy
 

Guy_M

XLDnaute Occasionnel
reBonjour seb8791,

Évidemment, j'ai eu aussi envie regrouper toutes les feuilles de plusieurs fichiers (classeurs) dans un seul et j'avais aussi écrit une macro pour ça.
A tester et adapter car je l'avais écrite pour Excel 2003 à l'origine.
VB:
'Cette procédure recopie toutes les feuilles excels des fichiers contenu dans le même répertoire que le classeur courant dans le classeur courant
'Inspiré par http://www.excel-downloads.com/forum/98695-est-il-possible-de-fusionner-plusieurs-documents-excel-en-un-seul.html
Sub ConsoliderClasseurs()
Dim ClasseurMaitre As Workbook 'Classeur courant dans lequel les feuilles vont être copiées
Dim ClasseurCourant As Workbook
Dim FeuilleCourante As Object
Dim NbClasseurs As Integer 'Nombre de classeurs consolidés
Dim Compteur As Integer 'Compteur de noms de feuille identiques
Dim NomFichier As String
Dim NomFeuilleCourante As String
Dim Reponse As VbMsgBoxResult
Dim SupprimerFeuillesExistantes As Boolean
Dim ListeNomsFichiers As String 'Listes des noms des fichiers à consolider saisies par l'utilisateur
Dim NomsFichiers As Variant 'Noms des fichiers en cours de consolidation
Dim TabNomsFichiers As Variant 'Tableau des noms de fichiers à reconsolider

#If Debogage Then
Reponse = MsgBox("ATTENTION, débogage en cours, continuer ?", vbYesNo + vbExclamation)
If Not Reponse = vbYes Then Exit Sub
#End If

#If True Then ' Not Debogage Then
If ActiveWorkbook.Path = "" Then
MsgBox "Répertoire inconnu, vous devez utiliser un classeur enregistré.", vbCritical
Exit Sub
End If
#End If

Set ClasseurMaitre = ActiveWorkbook

'Faire saisir les extensions
ListeNomsFichiers = InputBox("Les noms des fichiers à consolider devraient être de la forme <nomfichier.extension> séparés par des virgules <,> les caratères génériques <*,?> peuvent être utilisés", "Saisir les extensions des fichiers à collecter", "*.xls?,*.csv")
If ListeNomsFichiers <> "" Then
    TabNomsFichiers = Split(ListeNomsFichiers, ",")
Else 'Annulation
    Exit Sub
End If

Reponse = MsgBox("Souhaitez-vous consolider les classeurs <" & Join(TabNomsFichiers, ", ") & "> du répertoire <" & ClasseurMaitre.Path & "> vers <" & ClasseurMaitre.Name & "> ?", vbQuestion + vbYesNo)
If Reponse <> vbYes Then Exit Sub
  ChDir ClasseurMaitre.Path

If ClasseurMaitre.Sheets.Count <> 0 Then
    Reponse = MsgBox("Le classeur <" & ClasseurMaitre.Name & "> contient déjà des feuilles, voulez-vous les supprimer ?", vbQuestion + vbYesNoCancel)
    If Reponse <> vbYes And Reponse <> vbNo Then Exit Sub 'Annuler a été cliqué
    Application.ScreenUpdating = False 'Empêche les màj de l'affichage
    If Reponse = vbYes Then
        SupprimerFeuillesExistantes = True
        Application.DisplayAlerts = False
        For Each FeuilleCourante In ClasseurMaitre.Sheets
            If ClasseurMaitre.Sheets.Count <> 1 Then 'On ne peut pas supprimer toutes les feuilles d'un classeur
                FeuilleCourante.Delete
            Else
                FeuilleCourante.Name = "FeuilleRestante"
            End If
        Next 'FeuilleCourante
        Application.DisplayAlerts = True
    Else
        SupprimerFeuillesExistantes = False
    End If
End If

NbClasseurs = 0 'Aucun classeur n'a été consolidé
For Each NomsFichiers In TabNomsFichiers
  NomFichier = Dir(NomsFichiers)
  Do While NomFichier <> ""
    'On ne travaille pas avec le classeur dans lequel on consolide les feuilles
    If NomFichier <> ClasseurMaitre.Name Then
      'On ne travaille pas avec un classeur déjà ouvert pour éviter la gestion de l'enregistrement ou nom du fichier déjà ouvert
      If Not EstDansCollection(Workbooks, NomFichier) Then
          Set ClasseurCourant = Workbooks.Open(NomFichier, , True) 'Ouverture en lecture seule
          For Each FeuilleCourante In ClasseurCourant.Sheets
            'On gère la collision des noms car la longueur d'un nom de feuille est limitée à 31 caractères
            'Excel gère cette collision avec au moins 5 caractères " (n)" contre 2 ici "_n"
            'La première fois qu'un nom de feuille est rencontré on ne lui ajoute pas de numéro.
            Compteur = 1 'Première fois
            NomFeuilleCourante = FeuilleCourante.Name
            Do
                If Not FeuilleExiste(NomFeuilleCourante, ClasseurMaitre, se_ToutesFeuilles) Then Exit Do
                Compteur = Compteur + 1 'Le nom a été rencontré une fois de plus
                NomFeuilleCourante = Left(FeuilleCourante.Name, 31 - Len("_" & Compteur)) & "_" & Compteur
            Loop
            FeuilleCourante.Name = NomFeuilleCourante
            FeuilleCourante.Copy After:=ClasseurMaitre.Sheets(ClasseurMaitre.Sheets.Count)
            NbClasseurs = NbClasseurs + 1
            If SupprimerFeuillesExistantes Then 'Teste un booléen pour accélerer les tests : feuilleexiste parcourt la liste des feuilles
                If FeuilleExiste("FeuilleRestante", ClasseurMaitre, se_ToutesFeuilles) Then
                    Application.DisplayAlerts = False
                    ClasseurMaitre.Sheets("FeuilleRestante").Delete
                    SupprimerFeuillesExistantes = False
                    Application.DisplayAlerts = True
                End If
            End If
          Next
          ClasseurCourant.Close False 'On ferme sans sauvegarder car les noms des feuilles ont été modifiés
        Else
          Reponse = MsgBox("<" & NomFichier & "> est déjà ouvert, ses feuilles ne seront pas consolidées.", vbExclamation + vbInformation)
        End If
    End If
    NomFichier = Dir
  Loop
Next 'Extension
  Application.ScreenUpdating = True 'Autorise les màj de l'affichage
If NbClasseurs = 0 Then MsgBox ("Aucun ficiers correpondants à <" & ListeNomsFichiers & "> n'a été trouvé")
End Sub
Cette macro a besoin de fonctions complémentaires
VB:
'Cette fonction permet de savoir si un objet de nom Item est présent dans la collection Coln
'Code de leroissejp publié dans http://www.developpez.net/forums/d98510/logiciels/microsoft-office/excel/macros-vba-excel/vba-e-tester-fichier-deja-ouvert/
Function EstDansCollection(Coln As Object, Item As String) As Boolean
Dim obj As Object
On Error Resume Next
Set obj = Coln(Item)
EstDansCollection = Not obj Is Nothing
End Function

'Proposé par Pierre Fauconnier
'Sur le forum http://www.developpez.net/forums/d1091154/logiciels/microsoft-office/excel/macros-vba-excel/tester-lexistence-feuille-classeur/
'Paramètres
'NomFeuille : nom de la feuille dont l'existence est recherchée, devrait être string
Function FeuilleExiste(NomFeuille As Variant, Optional Classeur As Workbook = Nothing, Optional TypeFeuille As ChoixTypeFeuille = se_ToutesFeuilles) As Boolean
  Dim Feuille As Object
 
  FeuilleExiste = False
  If Classeur Is Nothing Then Set Classeur = ThisWorkbook
      'En détourant le traitement d'erreurs, c'est plus rapide
      'On ne teste pas le type de NomFeuille car si ce n'est pas le bon cela génère une erreur
      On Error Resume Next
      Set Feuille = Classeur.Sheets(NomFeuille)
      If Feuille Is Nothing Then Exit Function
      If TypeFeuille = se_ToutesFeuilles Or Feuille.Type = TypeFeuille Then
        FeuilleExiste = True
      End If
    Exit Function

End Function
A bientôt
Guy
 

Guy_M

XLDnaute Occasionnel
J'ai amélioré la macro pour regrouper les feuilles d'un classeur, pour plus de souplesse et parce que j'ai rencontré des difficultés avec UsedRange.Rows.Count (bug ?).

VB:
'Cette procédure regroupe toute les feuilles du classeur actif dans la feuille active
Sub FeuillesRegrouper()

Dim Reponse As VbMsgBoxResult
Dim FeuilCour As Worksheet
Dim FeuilleActive As Worksheet

Set FeuilleActive = ActiveSheet

Reponse = MsgBox("Souhaitez vous regroupe toute les feuilles visibles du classeur dans <" & FeuilleActive.Name & "> ?", vbQuestion + vbYesNo, "Continuer ?")
If Reponse <> vbYes Then Exit Sub

Application.ScreenUpdating = False

If FeuilleActive.Type <> xlWorksheet Then
  MsgBox "La feuille active doit être une feuille de calcul.", vbCritical
End If

'Réinitialisation du usedrange de la feuille active
ActiveSheet.UsedRange

For Each FeuilCour In ActiveWorkbook.Worksheets 'selectionne toutes les feuilles
  If Not FeuilCour.Visible Then GoTo FeuilleSuivante 'On ne copie que les feuilles visibles
  If FeuilCour.Name = FeuilleActive.Name Then GoTo FeuilleSuivante 'on ne copie le contenu de la feuille de destination sauf la première
  FeuilCour.UsedRange.Copy
  FeuilleActive.Paste Destination:=FeuilleActive.Range("A" & FeuilleActive.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1) 'Il y a un bug avec PremiereFeuille.UsedRange.Rows.Count
FeuilleSuivante:
Next

Application.ScreenUpdating = True

End Sub
A bientôt
Guy
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas