Sub CopyAllBook()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.CutCopyMode = False
Dim wb As Workbook
q = ThisWorkbook.Name

'открываем все книги в папке files
Dim MyName As String
Dim MyPath As String
Dim sPath As String
        MyPath = "C:\Users\Admin\Downloads\4075667\files\" 'тут указать где лежат файлы
        MyName = Dir(MyPath & "*.xls*")
         Do While MyName <> ""
            sPath = MyPath + MyName
            Excel.Application.Workbooks.Open sPath
            MyName = Dir
         Loop
             
'после открытия активируем основную рабочую книгу
Workbooks(q).Activate

'копируем в основную книгу данные с других книг
        For Each wb In Application.Workbooks
        LastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            If wb.Name <> q Then
                LR = wb.Worksheets("Описание АСР").Cells(Rows.Count, 6).End(xlUp).Row
                Workbooks(q).Worksheets("Описание АСР").Cells(LastRow + 1, 1).Value = Replace(wb.Name, ".xls", "")
                With Range("A" & LastRow + 1 & ":F" & LastRow + 1)
                .Merge
                .HorizontalAlignment = xlCenter
                .Font.Bold = True
                End With
                wb.Worksheets("Описание АСР").Range("A3:F" & LR).Copy
                Workbooks(q).Worksheets("Описание АСР").Cells(LastRow + 2, 1).PasteSpecial xlPasteAll

                    
                wb.Close
            End If
        Next
[A1].Activate
Application.CutCopyMode = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

"C:\Users\Admin\Downloads\4075667\files\"