Sub Кнопка1_Щелчок()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sPath$, sXLS$
sPath = "Z:\Documents\Табеля" & Application.PathSeparator ' указать директорию с файлами

     sXLS = Dir(sPath & "*.xls*")
     Do While sXLS <> ""
         Workbooks.Open sPath & sXLS
          
          
         'Тут процедура копирования. Еще нужно подумать, но мне пока некогда. Можно поискать готовое решение
          
          
         Workbooks(2).Close False
         sXLS = Dir
     Loop
      
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

    Dim wb As Workbook
     '...
     Set wb = Workbooks.Open(sPath & sXLS)
     'Тут процедура копирования. Еще нужно подумать, но мне пока некогда. Можно поискать готовое решение
     wb.Close False

Sub Собираем_диапазоны_выбранных_книг_и_всех_листов()
        
      Dim iRng As Range
      Dim iRngAddress As String, oAwb As String, oFile
      Dim lLastRow As Long, lLastRowMyBook As Long
      Dim iLastColumn As Integer
      Dim Str() As String
         
         
      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
          Sheet.Activate
          lLastRow = Cells(1, 1).SpecialCells(xlLastCell).Row
          iLastColumn = Cells(1, 1).SpecialCells(xlLastCell).Column
          lLastRowMyBook = ThisWorkbook.Worksheets(1).Cells(100, 1).SpecialCells(xlLastCell).Row
          iRngAddress = Range(Cells(lLastRowMyBook, 1), Cells(lLastRowMyBook + lLastRow, iLastColumn)).Address
          Sheet.Range(Cells(1, 1), Cells(lLastRow, iLastColumn)).Copy Destination:=ThisWorkbook.Worksheets(1).Range(iRngAddress)
             
      Next Sheet
          Workbooks(oAwb).Close False
      Next oFile
         
      End With
         
      Application.ScreenUpdating = True
End Sub

On Error Resume Next

Sub qq()
     On Error Resume Next
     For i = 1 To 6
         Set wb = Workbooks.Open("D:\" & i & ".xlsx")
         If Err Then
             strk = strk & " " & i
         End If
         wb.Close
         Err.Clear
     Next
     MsgBox (strk)
End Sub