Sub FactAvecCmd()
Const SousRépertoire = "\Suivi Top 50 - production 10 derniers jours (Avec commande)"
Dim Cible As Range, Source As Range, NF As String, N As Long, Z As String, LaDate As Date
Set Cible = ActiveWorkbook.Sheets(5).Rows(2)
Cible.Resize(65000).ClearContents
ChDrive ThisWorkbook.Path: ChDir ThisWorkbook.Path & SousRépertoire
NF = Dir("*.xls") ' premier fichier
Do While NF <> ""
Workbooks.Open Filename:=NF
Set Source = ActiveSheet.[A1].CurrentRegion: N = Source.Rows.Count - 1
Set Source = Source.Offset(1).Resize(N)
Source.Copy Destination:=Cible
ActiveWorkbook.Close False
Z = Right$(Split(NF, ".")(0), 10) ' JJ-MM-AAAA
Cible.Resize(N).Columns(4).Value = DateSerial(Right$(Z, 4), Mid$(Z, 4, 2), Left$(Z, 2))
Set Cible = Cible.Offset(N)
NF = Dir ' fichier suivant
Loop
End Sub