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 = ThisWorkbook
For i = LBound(Fich) To UBound(Fich)
Workbooks.Open Filename:=Fich(i), ReadOnly:=True
Set OldWBK = ActiveWorkbook
OldWBK.Sheets(1).Copy After:=AcWBK.Sheets(AcWBK.Sheets.Count)
AcWBK.ActiveSheet.Name = OldWBK.Sheets(1).Range("h2")
OldWBK.Close False
Next i
Application.DisplayAlerts = False
With ActiveWorkbook
'.Sheets(1).Delete
.SaveAs LePath & LeNom
End With
' Ne pas oublier
Application.DisplayAlerts = True
'Application.SheetsInNewWorkbook = nbf
' Ne pas oublier
Application.ScreenUpdating = True
End Sub