Fusionner plusieurs classeurs d'un répertoire

Bonjour le forum,

J'ai dans un répertoire bien défini, un ensemble de classeur à la structure identique.

J'aimerai, à l'aide d'une macro, récupérer les données de ces classeurs (dans l'onglet "synthèse") pour les synthétiser dans un classeur unique.

J'ai trouvé le code suivant, que j'ai essayé d'adapter :

Sub Compilation()

Dim Fichier As String
Dim Chemin As String
Dim ClasseurSource As Workbook
Dim DL As Integer

Application.DisplayAlerts = False 'Evite les messages d'Excel
Application.EnableEvents = False 'Evite l'exécution éventuelle de macros liées aux fichiers ouverts

Chemin = "C:\Users\utilisateur\Desktop\Fichiers\" 'Chemin du répertoire contenant les fichiers
Fichier = Dir(Chemin & "*.xlsm")
DL = Cells(Application.Rows.Count, 1).End(xlUp).Row 'Je définis la dernière ligne dont la colonne A n'est pas vide

Do While Fichier <> ""
    Set ClasseurSource = Workbooks.Open(Chemin & Fichier)
    CompteurClasseur = CompteurClasseur + 1
    ClasseurSource.Sheets("Synthèse").Select 'nom de la feuille source (commune à tous les fichiers sources)
    Range("A3:AC" & DL).Copy 'copie les données de la plage A3:AC jusqu'à la dernière remplie
    ThisWorkbook.Activate
    ThisWorkbook.Sheets("Extraction").Select
    Cells(65535, 1).End(xlUp)(2).Select 'recherche de la première ligne vide de mon fichier maitre
    ActiveSheet.Paste
    ClasseurSource.Close
    Fichier = Dir
Loop
 MsgBox "fusion de " & CompteurClasseur & " classeurs Excel.", vbInformation, "Import réussi"
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

C'est un bon début, mais j'ai dû faire une erreur : toutes les données de mes classeurs sources ne sont pas copiées, il me manque certaines lignes et parfois il me copie également les en-têtes de chaque classeur.

Quelqu'un peut-il me mettre sur une piste ?

Merci d'avance,

Bonjour lucas54000,

Voici un exemple,

Avant d’exécuter la macro, n’oublie pas de modifier les lignes qui ont un commentaire « à adapter »

Option Explicit
'nécessite d'activer la référence: Microsoft ActiveX Data Objects xx Library

Sub RequeteClasseurFerme()
Dim Feuille As String, Repertoire As String, Ligne As Long
Dim fso, sfofolder, oFile
Dim Cnn, texte_SQL As String, Rst As ADODB.Recordset

Repertoire = "C:\Users\isabelle\Documents\Test3"  'à adapter
Feuille = "Feuil1"      'à adapter
Ligne = 2
Sheets.Add After:=Sheets(Sheets.Count)

Set fso = CreateObject("Scripting.FileSystemObject")
Set sfofolder = fso.GetFolder(Repertoire)

For Each oFile In sfofolder.Files
    If Right(oFile, 5) = ".xlsx" Then  'à adapter

        Set Cnn = New ADODB.Connection
        '--- Connexion ---
        With Cnn
            .Provider = "Microsoft.Jet.OLEDB.12.0"
            .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
                        & oFile & ";Extended Properties=""Excel 12.0;HDR=NO;"""
            .Open
        End With

        'Définit la requête.
        texte_SQL = "SELECT * FROM [" & Feuille & "$]"

        Set Rst = New ADODB.Recordset
        Set Rst = Cnn.Execute(texte_SQL)

        'Ecrit le résultat de la requête dans la cellule A2
        Range("A" & Ligne).CopyFromRecordset Rst
        Rst.Close
        Ligne = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
    End If
Next
'--- Fermeture connexion ---
Cnn.Close
Set Rst = Nothing
Set Cnn = Nothing
End Sub

Merci infiniment i20100 et WOW je suis bluffé par la rapidité de cette requête... 1 clic et paf tout apparaît

Juste un tout petit problème, dans le résultat de la requête les entêtes de chaque fichiers sont copiées également à chaque fois.

ça donne :

Entêtes

Données fichier 1

Entêtes

Données fichier 2

Entêtes

Données fichiers 3

etc..

C'est possible d'y remédier ?

Encore merci à toi

Lucas

J'ai trouvé, j'ai modifié la ligne

"SELECT * FROM [" & Feuille & "$]"

par

texte_SQL = "SELECT * FROM [" & Feuille & "$A3:AC" & "]"

soit ma plage de données à importer.

Encore merci !

Bonjour Lucas,

à tester, enlève HDR=NO de la chaine de connection

        '--- Connexion ---
        With Cnn
            .Provider = "Microsoft.Jet.OLEDB.12.0"
            .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
                        & oFile & ";Extended Properties=""Excel 12.0;;"""
            .Open
        End With

ça marche super bien également, merci encore à toi pour ton aide

Super, Merci pour ce retour, au plaisir!