Fusionner les données des feuilles de plusieurs classeurs excel en un seul classeur

Commenter

Contenu du snippet

Ce code regroupe les données des feuilles de plusieurs classeurs Excel enregistrés dans le même dossier que ce classeur. Il permet de fusionner les données de plusieurs classeurs chacun ayant 3 feuilles en un seul classeur d'une seule feuille. les informations des classeurs différents seront mises les unes après les autres. une ligne noir permet de visualiser le changement de fichier
le compilateur va compiler de la manière suivante:
En colonne A à D les données des Feuilles n° 1
En colonne E à J les données des Feuilles n°2
En colonne K à M les données des feuilles n° 3

A la fin juste un petit message de confirmation indiquant le nombre de fichiers traités ainsi que la liste de ces derniers, cela pourra être utile pour contrôler.

j'espère que ca vous aide.....

Source / Exemple : 


Sub LaunchCompilation()
' Ce code doit servir à regrouper les données des feuilles de plusieurs classeurs Excel enregistrés dans le même dossier que ce classeur

Application.DisplayAlerts = False ' pour éviter les message demandant confirmation lors d'une fermeture (notamment le fait d'avoir des données dans le presse papier
chemin = ThisWorkbook.Path 'chemin du dossier qui contient les autres fichiers et où est enregistré ce fichier qui servira de compilateur
Set fso = New FileSystemObject 'l'utilisation des FSO nécessite l'activation de la référence Microsoft Scripting Runtime
Set dossier = fso.GetFolder(chemin) '
Dim r As Integer ' r sera le n° de la ligne de la feuille compilateur
r = 1
Dim nbfichiers ' nbfichier sera le nombre de fichiers traités
nbfichier = 0
Dim listedesfichierstraités As String

For Each fichier In dossier.Files ' boucle sur les fichiers
    If fso.GetExtensionName(fichier.Path) = "xls" And fichier.Name <> ThisWorkbook.Name Then 'sélection des fichiers à traiter : classeurs excel et pas le compilateur
    nbfichiers = nbfichiers + 1
    listedesfichierstraités = listedesfichierstraités & fichier.ShortName & Chr(10)
    Workbooks.Open fichier 'ouverture d'un fichier
    
        For i = 1 To ActiveWorkbook.Sheets.Count ' boucle sur les feuilles de ce fichier
        Sheets(i).Select 'sélection de la feuille
        
        
        Select Case i
        Case 1
        lastrow1 = Cells(65536, 3).End(xlUp).Row 'détermination de la dernière ligne à copier selon la présence de données dans la colonne C
        Range(Cells(1, 1), Cells(lastrow1, 4)).Copy 'copie des cellules de la plage A1:D dernière ligne
        ThisWorkbook.Activate 'on se place sur le fichier de compilation
        Sheets(1).Cells(r, 1).Select 'on sélectionne la 1ère feuille, et la première cellule encore vide de la colonne A
        ActiveSheet.Paste ' collage simple, si les données contiennent des formules peut-être mieux vaut un pastespecial
        Case 2
        lastrow2 = Cells(65536, 3).End(xlUp).Row 'détermination de la dernière ligne à copier selon la présence de données dans la colonne C
        Range(Cells(1, 1), Cells(lastrow2, 6)).Copy 'copie des cellules de la plage A1:F dernière ligne
        ThisWorkbook.Activate 'on se place sur le fichier de compilation
        Sheets(1).Cells(r, 5).Select 'on sélectionne la 1ère feuille, et la première cellule encore vide de la colonne E
        ActiveSheet.Paste ' collage simple, si les données contiennent des formules peut-être mieux vaut un pastespecial
        Case 3
        lastrow3 = Cells(65536, 3).End(xlUp).Row 'détermination de la dernière ligne à copier selon la présence de données dans la colonne C
        Range(Cells(1, 1), Cells(lastrow3, 3)).Copy 'copie des cellules de la plage A1:C dernière ligne
        ThisWorkbook.Activate 'on se place sur le fichier de compilation
        Sheets(1).Cells(r, 11).Select 'on sélectionne la 1ère feuille, et la première cellule encore vide de la colonne K
        ActiveSheet.Paste ' collage simple, si les données contiennent des formules peut-être mieux vaut un pastespecial
        End Select
        Cells(r, 1).EntireRow.Interior.ColorIndex = 1
        
                
        Workbooks(fichier.Name).Activate
        Next i
        
        If lastrow1 > lastrow2 And mastrow1 > lastrow3 Then
        lastrow = lastrow1
        Else
            If lastrow2 > lastrow1 And lastrow2 > lastrow3 Then
            lastrow = lastrow2
            Else
            lastrow = lastrow3
            End If
        End If
        
        r = r + lastrow 'on ajoute à r la dernière ligne pour toujours se placer sur la 1ère cellule vide de la colonne A
     
     
    Workbooks(fichier.Name).Close (False) 'on ferme le fichier ouvert précédemment
    End If
Next fichier
Application.DisplayAlerts = True 'on rétablie le paramétrage standard
Cells(1, 1).Select
MsgBox ("Le traitement est terminé." & Chr(10) & nbfichiers & " fichiers ont été traités, en voici la liste :" & Chr(10) & listedesfichierstraités)
End Sub

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.