Regrouper pls classeur de plusieurs feuille dans le meme cla

bonsoir tout le monde,

Je souhaite regrouper plusieurs fichiers excel de plusieurs feuille sous un seul classeur, j'ai exécuté la macro suivante mais elle ne me prend que la première feuille des classeur et me les regroupe dans un seul classeur ou je la lance :

Option Explicit

Public Sub regroupe()

Dim chemin As String ' classeur regroupé

Dim rep As String ' répertoire à traiter

Dim fic As String ' classeur regroupé

Dim ligne As Long ' ligne écriture

Dim nbc As Integer ' nombre de classeurs

Dim Wf As Worksheet ' feuille regroupement

Dim Wl As Worksheet ' feuille regroupée

With Application

.DisplayAlerts = False

.ScreenUpdating = False

End With

rep = ThisWorkbook.Path & "\"

On Error GoTo fin

Set Wf = ThisWorkbook.ActiveSheet ' variable feuille groupe

Wf.Cells.ClearContents

nbc = 0 ' initialisation variables

ligne = 1

fic = Dir(rep & "*.xls") ' recherche fichiers

While fic <> ""

If fic <> ThisWorkbook.Name Then

chemin = rep & fic ' chemin fichiers

Workbooks.Open chemin, 0 ' ouverture

Set Wl = ActiveWorkbook.Sheets(1)

Wl.Copy After:=Wf

Workbooks(fic).Close SaveChanges:=False ' Fermeture du classeur

nbc = nbc + 1

End If

fic = Dir

Wend

fin:

MsgBox nbc & " classeurs regroupés"

Application.DisplayAlerts = True

End Sub

je vous remercie par avance pour votre aide

Bonjour,

Pas testé, je t'en laisse le loisir :

Public Sub regroupe()

    Dim Cls As Workbook
    Dim Wl As Worksheet ' feuille regroupée
    Dim chemin As String ' classeur regroupé
    Dim rep As String ' répertoire à traiter
    Dim fic As String ' classeur regroupé
    Dim nbc As Integer ' nombre de classeurs

    With Application

        .DisplayAlerts = False
        .ScreenUpdating = False

    End With

    rep = ThisWorkbook.Path & "\"

    On Error GoTo fin

    nbc = 0 ' initialisation variables
    fic = Dir(rep & "*.xls") ' recherche fichiers

    While fic <> ""

        If fic <> ThisWorkbook.Name Then

            Set Cls = Workbooks.Open(rep & fic, 0) ' ouverture

            With Cls

                .Activate
                For Each Wl In .Worksheets: Wl.Select False: Next

            End With

            With ThisWorkbook

                ActiveWindow.SelectedSheets.Copy , .Sheets(.Sheets.Count)

            End With

            Cls.Close SaveChanges:=False ' Fermeture du classeur

            nbc = nbc + 1

        End If

        fic = Dir

    Wend

fin:
    MsgBox nbc & " classeurs regroupés"
    Application.DisplayAlerts = True

End Sub

MERCIIIIIIII ça marche au top