Как говорится "вдруг угадал" )))
[vba]Код
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
[/vba]
Только измените это
[vba]Код
"C:\Users\Admin\Downloads\4075667\files\"
[/vba]
на тот путь где у Вас будут лежать файлы с которых вы копируете.