VBA EXCEL: Собрать кучу файлов в один

Формулировка задачи:

В папке находится куча xls файлов. У всех у них одинаковая структура. Но она может меняться периодически. Необходимо все файлы собрать в один. Первый файл из которого будут браться данные копируется полностью, включая заголовки. А у последующих файлов данные беруться без заголовков

Решение задачи: «VBA EXCEL: Собрать кучу файлов в один»

textual
                            Листинг программы 
                        

                            Sub Собрать_данные_из_xls_файлов()
    ' Макрос создает книгу и последовательно вставляет на одноименные листы
    ' данные из всех xls файлов заданной директории начиная со строки FRow.
    Const FRow& = 2                ' Номер строки начала сбора данных (ниже шапки)
    Const Sborka$ = "Сборка.xls"   ' Имя сборочного файла
    Dim FCol&, LCol&               ' Переменные номеров первого и последнего столбца для сбора данных
    Dim LRow&, LRow_Cel&
    Dim wb_Cel As Workbook, wb_Tek As Workbook
    Dim Sh_Cel As Worksheet, Sh_Tek As Worksheet
    Dim MyPath$, MyFileName$, MyFulName$
    Dim Uslovie1 As Boolean
    
    ' Выбор папки
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Укажите рабочую папку": .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        MyPath = .SelectedItems(1) & "\"
    End With
      
       
    
       
    'MyPath = "C:\inbox\Тест Макроса\Тест\"
    ' MyPath = CurDir & "\"
    MyFileName = Dir(MyPath & "*.xls*")
    Uslovie1 = False
    Do Until MyFileName = ""
        If MyFileName <> Sborka Then
            MyFulName = MyPath & MyFileName
            Workbooks.Open Filename:=MyFulName, UpdateLinks:=0
            If Not Uslovie1 Then
                Set wb_Cel = ActiveWorkbook
                ActiveWorkbook.SaveAs Filename:=MyPath & Sborka, FileFormat:=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
                Uslovie1 = True
            Else
                Set wb_Tek = ActiveWorkbook
                For Each Sh_Cel In wb_Cel.Sheets
                    With Sh_Cel
                        FCol = .UsedRange.Cells(1, 1).Column
                        LCol = .UsedRange.Columns.Count + FCol - 1
                        LRow_Cel = .Cells(.Rows.Count, FCol).End(xlUp).Row + 1
                    End With
                    For Each Sh_Tek In wb_Tek.Sheets
                        If Sh_Tek.Name = Sh_Cel.Name Then
                            With Sh_Tek
                                LRow = .Cells(.Rows.Count, FCol).End(xlUp).Row
                                If LRow >= FRow Then
                                    .Range(.Cells(FRow, FCol), .Cells(LRow, LCol)).Copy Sh_Cel.Cells(LRow_Cel, 1)
                                End If
                            End With
                            With Sh_Cel
                                    Range(.Cells(LRow_Cel , 2+LCol-FCol), .Cells(LRow_Cel+LRow-FRow,  2+LCol-FCol))= MyFulName
                            End With
                        End If
                    Next Sh_Tek
                Next Sh_Cel
                Workbooks(MyFileName).Close SaveChanges:=False
            End If
        End If
        MyFileName = Dir
    Loop
End Sub
                        