Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer
    Dim S1 As Worksheet, S2 As Worksheet
    Application.ScreenUpdating = False  'отключаем обновление экрана для скорости
       
    'вызываем диалог выбора файлов для импорта
    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="all files (*.*), *.*", _
      MultiSelect:=True, Title:="Files to Merge")
   
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Не выбрано ни одного файла!"
        Exit Sub
    End If
    'проходим по всем выбранным файлам
    x = 1
  While x <= UBound(FilesToOpen)
        Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
        'проходим по всем листам
        For Each S1 In importWB.Worksheets
          S1.Copy , ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
          ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = S1.Name & " Из книги " & x
        Next S1
        importWB.Close 'savechanges:=False
        x = x + 1
    Wend
     
    Application.ScreenUpdating = True
End Sub