Option Explicit

Dim objFSO As Object, objFolder As Object, objFile As Object

Sub Get_All_File_from_SubFolders()
Dim BazaWb As Workbook 'текущая книга (общий файл)
Dim BazaSht As Worksheet 'сводный лист
    Dim sFolder As String
    'With Application.FileDialog(msoFileDialogFolderPicker)
        'If .Show = False Then Exit Sub
        'sFolder = .SelectedItems(1)
    'End With
    Set BazaWb = ThisWorkbook
    Set BazaSht = BazaWb.Sheets("Лист1")
    sFolder = BazaWb.Path
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    GetSubFolders sFolder, BazaSht
    Set objFolder = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
End Sub
Private Sub GetSubFolders(sPath, BazaSht)
Dim BazaSht As Worksheet
Dim iLastRowBaza As Long 'последняя заполненная строка в общем файле в столбце A
Dim iLastRowTempWb As Long 'последняя заполненная строка в по-очерёдно открываемом файле в столбце A
Dim iNumFiles As Long 'количество открываемых файлов
    Dim sPathSeparator As String, sObjName As String
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
            
           With Application.Workbooks.Open(Filename:=sPath & objFile.Name, UpdateLinks:=False, ReadOnly:=True)
                iNumFiles = iNumFiles + 1
                    With .Worksheets("Лист1")
                        'последняя строка в открытом файле
                        If .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1).MergeCells Then
                            iLastRowTempWb = .Cells(Rows.Count, 2).End(xlUp).Row + 1
                        Else
                            iLastRowTempWb = .Cells(Rows.Count, 2).End(xlUp).Row
                        End If
                        'последняя строка в базе
                        If BazaSht.Cells(Rows.Count, 1).End(xlUp).MergeCells Then
                            iLastRowBaza = BazaSht.Cells(Rows.Count, 2).End(xlUp).Row + 2
                        Else
                            iLastRowBaza = BazaSht.Cells(Rows.Count, 2).End(xlUp).Row + 1
                        End If
                        .Range(.Cells(3, 1), .Cells(iLastRowTempWb, 15)).Copy Destination:=BazaSht.Cells(iLastRowBaza, 1)
                    End With
            'ActiveWorkbook.Sheets(1).Range("A1").Value = "www.excel-vba.ru"
            'ActiveWorkbook.Close True
        End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.Path & Application.PathSeparator
    Next
End Sub

GetSubFolders objFolder.Path & Application.PathSeparator

GetSubFolders objFolder.Path & Application.PathSeparator, BazaSht

iNumFiles = iNumFiles + 1

iNumFiles1 = iNumFiles1+iNumFiles

iNumFiles1=0