Sub Fusion_Fichier()
Application.ScreenUpdating = False
ChDir ActiveWorkbook.Path
Extension = "Excel Files (*.xls),*.xls"
TypeFiltre = 10
Titre = "Sélectionnez plusieurs fichiers (Maintenir CTRL pour sélectionner plusieurs)"
fich = Application.GetOpenFilename(FileFilter:=Extension, _
FilterIndex:=TypeFiltre, Title:=Titre, MultiSelect:=True)
If Not IsArray(fich) Then Exit Sub
LePath = ActiveWorkbook.Path & "\"
LeNom = "Fusion du " & Format(Date, "dd_mmmm_yy")
nbf = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Workbooks.Add
Set AcWbk = ActiveWorkbook
For i = LBound(fich) To UBound(fich)
Workbooks.Open Filename:=fich(i)
Set OldWbk = ActiveWorkbook
OldWbk.Sheets(1).Copy After:=AcWbk.Sheets(AcWbk.Sheets.Count)
OldWbk.Close False
Next i
Application.DisplayAlerts = False
With ActiveWorkbook
.Sheets(1).Delete
.SaveAs LePath & LeNom
End With
Application.SheetsInNewWorkbook = nbf
End Sub