Sub Макрос2()
'
' Макрос2 Макрос
'
' Сочетание клавиш: Ctrl+ц
'
    Sheets("производство").Select
    Range("B2:I2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("ВЕСЬ ПЕРСОНАЛ").Select
    Range("B2").Select
    ActiveSheet.Paste
    
    Sheets("склад").Select
    Range("B2:I2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("ВЕСЬ ПЕРСОНАЛ").Select
    Selection.End(xlDown).Select
    Range("B96").Select
    ActiveSheet.Paste
    Sheets("учебный центр").Select
    Range("B2:I2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("ВЕСЬ ПЕРСОНАЛ").Select
    Selection.End(xlDown).Select
    Range("B99").Select
    ActiveSheet.Paste
    Sheets("АХО").Select
    Range("B2:I2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("ВЕСЬ ПЕРСОНАЛ").Select
    Selection.End(xlDown).Select
    Selection.End(xlUp).Select
    Range("B100").Select
    ActiveSheet.Paste
    Sheets("бухгалтерия").Select
    Range("B2:I2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("ВЕСЬ ПЕРСОНАЛ").Select
    Selection.End(xlDown).Select
    Range("B110").Select
    ActiveSheet.Paste


End Sub

Sub simpleXlsMerger2()
Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")
 
'указать путь к папке с файлами
Set dirObj = mergeObj.Getfolder("C:\Users\HP\Downloads\сборка\")
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)
 
'вместо "A2" указать адрес ячейки в каждом файле, с которой начинать сборку
'например, "B3:IV" объединит все данные из файлов, начиная с ячейки B3
'Если колонок больше, чем IV, поменять соответственно
'В "A65536" вместо "A" указать тот же столбец, что и в адресе первой ячейки
Range("A1:IV" & Range("A65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate
 
'Здесь столбец не менять
Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
bookList.Close
Next
    Range("A1").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Range("A5").Select
    Selection.End(xlToRight).Select
    Range("E5").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(""31.12."",YEAR(RC[-1]))"
    Range("F5").Select
    ActiveCell.FormulaR1C1 = "=YEAR(RC[-2])"
    ActiveCell.SpecialCells(xlLastCell).Select
    Selection.End(xlToLeft).Select
    Range("F538").Select
    Range(Selection, Selection.End(xlUp)).Select
    Range("E5:F538").Select
    Range("F538").Activate
    Selection.FillDown
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Range("A2:C2").Select
    Application.CutCopyMode = False
    

    Range("E4").Select
    ActiveCell.FormulaR1C1 = "Реестр договоров по состоянию на"
    Range("F4").Select
    ActiveCell.FormulaR1C1 = "Год"
    Rows("4:4").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Cells.Select
    Selection.ColumnWidth = 11.57
    Rows("3:3").Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.Delete Shift:=xlUp
    Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$I$538").AutoFilter Field:=4, Criteria1:="="
    ActiveCell.SpecialCells(xlLastCell).Select
    Rows("538:538").Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Cells(1)).Select
    Rows("53:538").Select
    Range("A538").Activate
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    ActiveSheet.Range("$A$1:$I$415").AutoFilter Field:=4
    ActiveWorkbook.Save
End Sub

Sub simpleXlsMerger3()

Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Dim rr As Range, llastr&
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")
   
  
Set dirObj = mergeObj.Getfolder("C:\Users\HP\Downloads\сборка\")
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)
   
'вместо "A2" указывается адрес ячейки в каждом файле, с которой начинать сборку
'например, "B3:IV" объединит все данные из файлов, начиная с ячейки B3
Set rr = Range("A1:IV" & Cells(Rows.Count, 1).End(xlUp).Row)
   
'Здесь столбец не менять
With ThisWorkbook.Worksheets(1)
    llastr = .Cells(.Rows.Count, 1).End(xlUp)
    rr.Copy .Range("A" & llastr + 1)
    'имя файла
    .Cells(llastr + 4, rr.Columns.Count - 250).Resize(rr.Rows.Count).Value = Left(everyObj.Name, 4)
    'значение из ячейки D1(правда, непонятно из какого листа - поэтому из 1)
    .Cells(llastr + 4, rr.Columns.Count - 251).Resize(rr.Rows.Count).Value = bookList.Sheets(1).Range("D1").Value
End With
  
bookList.Close
Next
End Sub

Sub simpleXlsMerger()
Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")
 

Set dirObj = mergeObj.Getfolder("C:\Users\HP\Downloads\сборка\")
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)
 
'вместо "A2" указывается адрес ячейки в каждом файле, с которой начинать сборку
'например, "B3:IV" объединит все данные из файлов, начиная с ячейки B3
Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate
 
'Здесь столбец не менять
Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False

everyObj.Name.Copy
Range("A65536").End(xlUp).Offset(1, -5).PasteSpecial

bookList.Close
Next
End Sub

Sub main()
    Set wa = CreateObject("Word.Application")
    wa.Visible = True: Set wd = wa.Documents.Open "C:\Users\HP\Downloads\РАСЧЕТ.docx"
    [b6:c51].Copy
    wd.Range.PasteExcelTable False, False, False
    Application.CutCopyMode = False
End Sub