Sub CombineWorkbooks()

    Dim FilesToOpen

    Dim x As Integer

    Application.ScreenUpdating = False 
'отключаем обновление экрана для скорости

     

    'вызываем диалог выбора файлов для импорта

    FilesToOpen = Application.GetOpenFilename _

      (FileFilter:="Excel files (*.xls), *.xls", _

      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))

        Sheets(1).Copy
After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

       
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = importWB.Name

        importWB.Close
'savechanges:=False

        x = x + 1

    Wend

    Application.ScreenUpdating = True

End Sub 

Dim TmpLastRow As Long 'последняя заполненная строка в поочерёдно открываемом файле в столбце A
Dim i As Long 'Переменная-счетчик цикла
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        Set MainWB = ThisWorkbook
        sPath = ThisWorkbook.Path & "\"
        FreeRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
        TmpFileName = Dir(sPath & "*.xls*")
        Do While TmpFileName <> ""
            If TmpFileName <> ThisWorkbook.Name Then
                With .Workbooks.Open(Filename:=sPath & TmpFileName, UpdateLinks:=False, ReadOnly:=True)
                     With .Worksheets(1)
                          TmpLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
                          .Range(.Cells(6, 1), .Cells(TmpLastRow, 35)).Copy MainWB.Sheets(1).Cells(FreeRow, 1)
                     End With
                     .Close saveChanges:=False
                End With
            End If
            TmpFileName = Dir
            FreeRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
        Loop
        FreeRow = Cells(Rows.Count, 1).End(xlUp).Row
        For i = 6 To FreeRow
            Cells(i, 1) = i - 5
        Next
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub