let
    f=(x)=>Excel.CurrentWorkbook(){[Name=x]}[Content],
    g=(x)=>[a=Record.Field(dict,x&".xlsx"),
            b=Excel.Workbook(a),
            c=b{0}[Data]][c],

    from = Folder.Files(f("adres"){0}[Column1])[[Name],[Content]],
    dict = Record.FromList(from[Content],from[Name]),
    lst=List.Select(f("range")[Column1],(x)=>x<>0),
    tr=List.Transform(lst,g),
    to=Table.Combine(tr)
in
    to


Option Explicit

Sub CombineWorkbooksAutomatically()
    Dim x           As Long
    Application.ScreenUpdating = False

    Dim TargetWorkbook As Workbook: Set TargetWorkbook = ThisWorkbook

    ' "Путь к вашей папке Рабочая книга"
    Dim SourceFolder As String: SourceFolder = ThisWorkbook.Path & "\Рабочая книга" & "\"

    Dim LastRow     As Long: LastRow = TargetWorkbook.Worksheets(1).Cells(TargetWorkbook.Worksheets(1).Rows.Count, "J").End(xlUp).Row

    ' Предполагается, что строка заголовков находится в первой строке, поэтому начинаем с 2
    For x = 2 To LastRow
        Dim SourceFileName As String: SourceFileName = TargetWorkbook.Worksheets(1).Cells(x, "J") & ".xlsx"
        Dim SourceFilePath As String: SourceFilePath = SourceFolder & "\" & SourceFileName

        ' Проверяем, существует ли файл в указанной папке
        If Dir(SourceFilePath) <> "" Then
            Dim importWB As Workbook: Set importWB = Workbooks.Open(Filename:=SourceFilePath)
            
            ' Исключаем расширение ".xlsx"
            Dim newSheetName As String: newSheetName = Left(SourceFileName, Len(SourceFileName) - 5)
            importWB.Worksheets(1).Copy After:=TargetWorkbook.Worksheets(TargetWorkbook.Sheets.Count)
            
            ' Задаем имя листа
            TargetWorkbook.Worksheets(TargetWorkbook.Sheets.Count).Name = newSheetName
            importWB.Close SaveChanges:=False
        Else
            MsgBox "Файл '" & SourceFileName & "' не найден в папке '" & SourceFolder & "'.", vbExclamation, "Ошибка"
        End If
    Next x

    Application.ScreenUpdating = True
    MsgBox "Операция по слиянию Листов Книг из: " & SourceFolder & vbNewLine & "в одну Книгу Выполнено Успешно! "
End Sub



Option Explicit

Sub CombineAllWorkbooksAutomatically()
    Dim x           As Long
    Dim ws          As Worksheet
    Application.ScreenUpdating = False

    ' Создаем новую книгу
    Dim NewWorkbook As Workbook: Set NewWorkbook = Workbooks.Add

    ' "Путь к вашей папке Рабочая книга"
    Dim SourceFolder As String: SourceFolder = ThisWorkbook.Path & "\Рабочая книга" & "\"

    Dim LastRow     As Long: LastRow = ThisWorkbook.Worksheets(1).Cells(ThisWorkbook.Worksheets(1).Rows.Count, "J").End(xlUp).Row

    For x = 2 To LastRow

        ' Включаем все форматы файлов Excel
        Dim SourceFileName As String: SourceFileName = ThisWorkbook.Worksheets(1).Cells(x, "J") & ".*"
        Dim SourceFilePath As String: SourceFilePath = SourceFolder & "\" & SourceFileName
        Dim foundFile As String: foundFile = Dir(SourceFilePath)

        Do While Len(foundFile) > 0
            Dim importWB As Workbook: Set importWB = Workbooks.Open(Filename:=SourceFolder & "\" & foundFile)

            For Each ws In importWB.Worksheets
                ws.Copy After:=NewWorkbook.Sheets(NewWorkbook.Sheets.Count)

                ' Исключаем все расширения из имён Книг
                Dim newSheetName As String: newSheetName = Left(foundFile, InStrRev(foundFile, ".") - 1)

                ' Задаем имя листа
                NewWorkbook.Sheets(NewWorkbook.Sheets.Count).Name = ws.Name & " " & newSheetName
            Next ws

            importWB.Close SaveChanges:=False

            ' Поиск следующего файла с тем же именем, но другим расширением
            foundFile = Dir
        Loop

    Next x

    ' Отключаем предупреждения
    Application.DisplayAlerts = False

    ' Удалить лист под индексом 1
    NewWorkbook.Sheets(1).Delete

    ' Включаем предупреждения
    Application.DisplayAlerts = True

    ' Сохраняем новую книгу
    Dim SavePath    As String: SavePath = ThisWorkbook.Path & "\Объединенная Книга.xlsx"
    NewWorkbook.SaveAs SavePath

    ' Закрываем новую книгу
    NewWorkbook.Close SaveChanges:=False

    Application.ScreenUpdating = True
    MsgBox "Операция по слиянию Листов Книг из: " & SourceFolder & vbNewLine & "в новую Книгу Выполнена Успешно! "
End Sub