Sub Кнопка8_Щелчок()
     Dim iPivotRange As Range, iDestinationRange As Range, iBeginRange As Range, Sheet
     Dim iRngAddress As String, oAwb As String, DataSheet As String, _
         iCopyAddress As String, sSheetName As String, oFile
     Dim lLastrow As Long, lLastRowMyBook As Long
     Dim iLastColumn As Integer
     Dim Str() As String

     ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
     DataSheet = ThisWorkbook.ActiveSheet.Name
     On Error Resume Next
     Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _
                    "1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _
                    vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8)
     If iBeginRange Is Nothing Then Exit Sub
     sSheetName = "Лист3"
     If sSheetName = "" Then sSheetName = "*"
     On Error GoTo 0
     With Application.FileDialog(msoFileDialogFilePicker)
         .AllowMultiSelect = True
         .InitialFileName = "*.*"
         .Title = "Выберите файлы"
         If .Show = False Then Exit Sub
         For Each oFile In .SelectedItems
             Workbooks.OpenText Filename:=oFile
             oAwb = Dir(oFile, vbDirectory)

             Application.ScreenUpdating = False
             Workbooks(oAwb).Activate
             For Each Sheet In Sheets
                 If Sheet.Name Like sSheetName Then
                     Sheet.Activate
                     Select Case iBeginRange.Count
                     Case 1
                         lLastrow = Cells(1, 1).SpecialCells(xlLastCell).Row
                         iLastColumn = Cells.SpecialCells(xlLastCell).Column
                         iCopyAddress = Range(Cells(iBeginRange.Row, iBeginRange.Column), Cells(lLastrow, iLastColumn)).Address
                     Case Else
                         iCopyAddress = iBeginRange.Address
                         lLastrow = iBeginRange.Rows.Count
                         iLastColumn = iBeginRange.Columns.Count
                     End Select
                     lLastRowMyBook = ThisWorkbook.Sheets(DataSheet).Cells.SpecialCells(xlLastCell).Row + 1
                     iRngAddress = Range(Cells(lLastRowMyBook, 1), Cells(lLastRowMyBook + lLastrow, iLastColumn)).Address
                     Sheet.Range(iCopyAddress).Copy Destination:=ThisWorkbook.Sheets(DataSheet).Range(iRngAddress)
                 End If
             Next Sheet
             Workbooks(oAwb).Close False
         Next oFile
     End With
     Application.ScreenUpdating = True
End Sub

.AllowMultiSelect = False

.AllowMultiSelect = True

Sub push_me_hard()
      Dim fPath$
      Dim spPath, spName
      Dim a()
      Dim i&
      With Application.FileDialog(msoFileDialogFilePicker)
          .Filters.Clear
          .Filters.Add "Microsoft Excel files", "*.xls"
          .AllowMultiSelect = True
          .InitialFileName = ThisWorkbook.Path
          If .Show = 0 Then Exit Sub
          fPath = .SelectedItems(1)
      End With
      spPath = Split(Replace(fPath, ".xls", ""), "\")         'отрезали от имени лишнее
      spName = Split(spPath(UBound(spPath)), "-")             'обозначили разделитель
      Application.ScreenUpdating = False
      Workbooks.Open fPath                    'открыли выбранную книгу
      With ActiveWorkbook                    'назначили книгу активной
          With .ActiveSheet                    'назначили лист активным
              a = .Range("A2:D" & .Cells(Rows.Count, 1).End(xlUp).Row).Value 'скопировали в буфер диапазон
          End With
          .Close False                    'закрыли книгу
      End With
      With Sheets("Сбор")                    'начинается цикл заполнения данными
          lr = .Cells(Rows.Count, 1).End(xlUp).Row + 1
          For i = 1 To UBound(a)
              If a(i, 1) <> "" Then
                  .Cells(lr, 1) = spName(0)
                  .Cells(lr, 2) = spName(2)
                  .Cells(lr, 3) = a(i, 1)
                  .Cells(lr, 4) = a(i, 3)
                  .Cells(lr, 5) = a(i, 4)
                  lr = lr + 1
              End If
          Next
      End With 'а наверно тут надо добавить циклический перебор выделенных файлов
      Application.ScreenUpdating = True
      Beep
End Sub