Sub Выбор_нескольких_файлов()
     Dim i As Long    '!!!
     Dim il As Long
     Dim a()

     'диалог для выбора файла
     Dim fd As FileDialog    'объектная переменная диалог выбора выбора файлов и папок
     Set fd = Application.FileDialog(msoFileDialogFilePicker)    'тип диалога выбор файла

     fd.AllowMultiSelect = True    'включить выбор множества файлов
     fd.Filters.Clear    'очистить фильтры типов файлов, если он запомнил их
     fd.Filters.Add "Файлы Excel-я", "*.xls;*.xlsx"    'выбор только файлов екселя

     fd.Show    'открыт диалог

     If fd.SelectedItems.Count = 0 Then    'если не выбрали файл то "ошибка"
         MsgBox "Не выбрали файл"
         Exit Sub
     End If

     Application.ScreenUpdating = False

     'Заполняю шапку таблицы
     Range("A1").Value = "№ анкеты"
     Range("B1").Value = "Фамилия"
     Range("C1").Value = "Имя"
     Range("D1").Value = "Отчество"

     For i = 1 To fd.SelectedItems.Count    'перебор имён файлов
         With GetObject(fd.SelectedItems(i))    'открываем
             a = .Sheets(1).[b5:b10].Value    'берём данные в массив
             .Close False    'закрываем без сохранения изменений (их правда и нет)
         End With
         il = Range("A" & Rows.Count).End(xlUp).Row + 1    'определяем последнюю строку
         Cells(il, 1) = a(1, 1)    ' в неё и перекладываем данные из массива
         Cells(il, 2) = a(3, 1)
         Cells(il, 3) = a(5, 1)
         Cells(il, 4) = a(6, 1)
     Next i

     'форматирую всю таблицу
     With Range("A1").CurrentRegion
         .Borders.ColorIndex = 1          'сетка черного цвета
         .Columns.AutoFit                 'автовыравнивание
         With .Rows(1)    'для 1 строки заголовка
             .Font.Bold = True    'жирный шрифт
             .Interior.ColorIndex = 38    'цвет фона
             .HorizontalAlignment = xlCenter  'по центру
         End With
     End With

     Application.ScreenUpdating = True

End Sub