Fusion plusieurs classeurs en un seul classeur

Bonjour,

Je souhaiterais obtenir ce résultat par Macro ou Power Query mais je n'ai pas trouvé de solution malgré mes recherches.

Je reçois de plusieurs personnes des classeurs (1-21, 1-22, 1-23,1-24 etc) et je voudrais regrouper le tout sur une seul feuille Excel

Je peut le faire manuellement mais j'en reçois trop d'un coup.

Le but est que j'ai ma feuille "BASE" avec l'entête du 1er tableau et ensuite tout ce met à la suite sauf la dernière ligne total.(Résultat souhaité en PJ)

Tout mes fichiers Excel sont dans un seul dossier.

Si quelqu'un à une idée et pourrais m'aider ce serait cool.

Merci d'avance.

Cordialement,

Dans quel dossier se trouvent les fichiers à importer par rapport au collecteur "résultat" ?

Bonjour le dossier se nomme IK et se trouve sur mon bureau le chemin est le suivant C:\Users\maver\Desktop\IK dedans il y à tous les classeurs Excel.

Mon fichier Résultat souhaité se trouve dedans aussi.

Cordialement,

Une proposition :

Option Explicit

Sub Fusion()
    Dim chemin As String, fichier As String
    Dim wB1 As Workbook, wB2 As Workbook
    Dim wS1 As Worksheet, wS2 As Worksheet
    Dim nL1 As Long, nL2 As Long, i As Long, compt As Long

    Set wB1 = ThisWorkbook
    Set wS1 = wB1.Sheets("BASE")
    ' Le dossier de l'ensemble des fichiers peut se trouver n'importe où
    chemin = wB1.Path
    ' Initialisation
    nL1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
    compt = 1
    ' Les fichiers à importer ont tous l'extension xslx
    fichier = Dir(chemin & "\*.xlsx")

    ' Pas de rafraîchissement d'écran à l'ouverture des classeurs
    Application.ScreenUpdating = False

    ' On traite un à un les lignes des fichiers trouvés, sauf la dernière (total de kms)
    Do While fichier <> ""
        Workbooks.Open chemin & "\" & fichier
        fichier = Dir
        Set wB2 = ActiveWorkbook
        Set wS2 = wB2.Sheets(1)
        ' Ligne des kms (= dernière)
        nL2 = wS2.Cells(Rows.Count, "A").End(xlUp).Row
        For i = 2 To nL2 - 1
            compt = compt + 1
            wS2.Range("A" & i & ":I" & i).Copy Destination:=wS1.Range("A" & compt)
        Next i
        ' On referme le classeur
        wB2.Close SaveChanges:=False
    Loop
    Application.ScreenUpdating = True

    ' On libère la mémoire
    Set wB1 = Nothing
    Set wB2 = Nothing
    Set wS1 = Nothing
    Set wS2 = Nothing
End Sub

Bonjour,

Tout marche bien merci pour cette aide, je vais essayer de comprendre le code

Cordialement,