Const FRow& = 5                ' Номер строки начала сбора данных (ниже шапки)
  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
        

          

Set myobject = CreateObject("Scripting.FileSystemObject")
Set mysource = myobject.GetFolder(MyPath)


For Each mySubFolder In mysource.SubFolders
    Set mysource = myobject.GetFolder(mySubFolder.Path)
    For Each MyFile In mysource.Files

    MyFileName = Dir(mysource & "\*.xls*")
    ''' Do Something with files in sub folders





    Uslovie1 = False
    Do Until MyFileName = ""

        If MyFileName <> ThisWorkbook.Name Then
            MyFulName = mysource & "\" & MyFileName
            Workbooks.Open Filename:=MyFulName, UpdateLinks:=0
            
            
            If Not Uslovie1 Then
                Set wb_Cel = ActiveWorkbook
               Application.DisplayAlerts = False
                ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & 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







    Next
Next