Доброго дня, друзья. Помогите, пожалуйста, со сборкой файла.
Требуется макросом собрать таблицы из файлов в одну таблицу в одном новом файле и добавить в эту новую таблицу названия файлов, из которых собрали данные в столбец,(например,в крайний справа), в каждую строку соответственно - чтобы понимать,какая строка из файла с каким названием.
И второе , добавить в еще один столбец (например,также в крайний справа) , в каждую строку - дату соответствующего реестр (она в каждом файле в ячейке D1)
Примеры файлов для сборки во вложении. Размеры таблиц в них всегда небольшие.
Код есть основной но дальше не получается..
Требуется макросом собрать таблицы из файлов в одну таблицу в одном новом файле и добавить в эту новую таблицу названия файлов, из которых собрали данные в столбец,(например,в крайний справа), в каждую строку соответственно - чтобы понимать,какая строка из файла с каким названием.
И второе , добавить в еще один столбец (например,также в крайний справа) , в каждую строку - дату соответствующего реестр (она в каждом файле в ячейке D1)
Примеры файлов для сборки во вложении. Размеры таблиц в них всегда небольшие.
Код есть основной но дальше не получается..
Код |
---|
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 |