Sub Regroupe()
Application.ScreenUpdating = False
Dim i As Integer
Dim Premlg As Integer, Derlg As Integer
'Efface les anciennes données
Derlg = Sheets("BD").Range("A65536").End(xlUp).Row
Sheets("BD").Range("A2:W" & Derlg).ClearContents
'A partir de la 2ème feuille jusqu'à la dernière
For i = 2 To Worksheets.Count
'Avec la 1ère feuille concernée
With Sheets(i)
'Copie les données de A2 à V dernière ligne non vide et les colle dans la 1ère cellule vide de la colonne A de la feuille "BD"
.Range("A2", .Cells(.Range("A65536").End(xlUp).Row, 25)).Copy Destination:=Sheets("BD").Range("A65536").End(xlUp)(2)
'Marque le nom de la feuille en colonne W
Premlg = Sheets("BD").Range("W65536").End(xlUp).Row + 1
Derlg = Sheets("BD").Range("A65536").End(xlUp).Row
Sheets("BD").Range("W" & Premlg & ":W" & Derlg) = Sheets(i).Name
End With
'Feuille suivante
Next i
End Sub