Sub multiselection()
Dim rep As Long
Dim Liste, StrPath, StrName, nomfich, Name As String
Dim compteur As Byte
Dim DernLigne, DernLigneA As Integer
StrPath = "Q:\cbi\CBI30_Pub\Planung\CR-reports\"
StrName = InputBox("Please choose the new Workbook's name")
'Strnamecomplet = Strname & ".xlsx"
Workbooks.Add
Worksheets(1).SaveAs (StrPath & StrName)
DernLigne = Workbooks(StrName).Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
' Affichage de la boîte de dialogue standard "Ouvrir" pour sélection de(s) fichier (s)
ChDir StrPath
nomfich = Application.GetOpenFilename(Title:="Choose the files to open", MultiSelect:=True)
' si aucun choix effectué, sortie du programme
If TypeName(nomfich) = "Boolean" Then
'MsgBox("Aucun fichier n'a été sélectionné. Fin de la procédure", vbCritical + vbOKOnly,"Sortie")
Exit Sub
End If
Application.DisplayAlerts = False
For compteur = 1 To UBound(nomfich)
DernLigne = Workbooks(StrName).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
Workbooks.Open Filename:=nomfich(compteur)
Name = Right(nomfich(compteur), Len(nomfich(compteur)) - 40)
Workbooks(Name).Activate
DernLigneA = Workbooks(Name).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
Range("A2", (Cells(DernLigneA, 42))).Copy
'Workbooks(Strname).Worksheets(1).Cells(DernLigneA, 1).Paste
Workbooks(StrName).Worksheets(1).Range(Cells(DernLigneA, 1)).Paste
Workbooks(Name).Close
Next compteur
Application.DisplayAlerts = True
End Sub