Страницы: 1
RSS
Макросом собрать таблицы из файлов в одну и добавить названия файлов этих в столбец
 
Доброго дня, друзья. Помогите, пожалуйста, со сборкой файла.

Требуется макросом собрать таблицы из файлов в одну таблицу в одном новом файле и добавить в эту новую таблицу названия файлов, из которых собрали данные  в столбец,(например,в крайний справа), в каждую строку соответственно - чтобы понимать,какая строка из файла с каким названием.
И второе , добавить в еще один столбец (например,также в крайний справа) , в каждую строку - дату соответствующего реестр (она в каждом файле в ячейке 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
 
 
Есть готовый вариант: Как собрать данные с нескольких листов или книг?
Ну или Ваш можно Допилить, но работоспособность не проверял:
Код
Sub simpleXlsMerger()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("A2: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+1,rr.columns.count+1).Resize(rr.rows.count).value = everyObj.Name
    'значение из ячейки D1(правда, непонятно из какого листа - поэтому из 1)
    .Cells(llastr+1,rr.columns.count+2).Resize(rr.rows.count).value = bookList.Sheets(1).Range("D1").value
end with
 
bookList.Close
Next
End Sub
Изменено: Дмитрий(The_Prist) Щербаков - 25.02.2020 18:05:41
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Да, данные-то собираются в новую общую таблицу. А вот с добавлением названий файлов и даты так и не получается.
Сейчас видно, что файлы макрос перебирает, чтобы дату взять из D1 (всегда с первого листа,и единственного).
Теперь нужно добавить же Paste, чтобы вставлялись даты и название файлов (годы) соответственно по строкам?
 
Цитата
OlegMTS написал:
Теперь нужно добавить же Paste
куда и зачем? Я код привел, который должен все это делать. Какой Paste Вам еще нужен? Он вообще не всегда нужен, особенно, если его применять там, где он не работает.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Да, в примере на форуме тоже этой команды вижу нет) теперь понятно.
Только результат по этому коду тот же пока что, только собирает таблицы в одну новую. А даты и годы не проставляются построчно((

Хотя видно, что файлы как будто быстро открываются-закрываются, то есть макрос файлы перебирает в папке,чтобы дату получается взять из d1.
А в новую таблицу не вставляются
 
Цитата
OlegMTS написал:
А в новую таблицу не вставляются
Вижу, что
= everyObj.Name  
= bookList.Sheets(1).Range("D1").value

вот тут должно записываться в ячейки построчно, и Paste получается,конечно, не нужен, но только пустота,ничего не записывается
 
Цитата
OlegMTS написал:
но только пустота,ничего не записывается
1. А где смотрите? Должно записываться в последние столбцы. Т.е. судя по коду имя файла должно быть в столбце AW, а данные из D1 - в AX.
2. А есть ли что-то в D1 первого ПО СЧЕТУ листа?
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Цитата
Дмитрий(The_Prist) Щербаков написал: 1. А где смотрите? Должно записываться в последние столбцы. Т.е. судя по коду имя файла должно быть в столбце AW, а данные из D1 - в AX.
upd: см.следующее сообщение

Да, Дмитрий, нашлись) даже не знаю как еще называть такие "грустные приколы"..когда сам же написал добавлять в крайний правый, хотя имел ввиду в следующий столбец после последнего вставленного, то есть в E и в F..
Почти в крайние правые и вставились, только в IW и IX. Из D1 тоже копируются (в IX)
Спасибо.

Я теперь пытаюсь сделать чтобы в E и в F вставлялись.  И чтобы имя файла копировалось не "2010.xlsx", а без .xlsx
Изменено: OlegMTS - 26.02.2020 01:57:49
 
Цитата
Дмитрий(The_Prist) Щербаков написал:
Изменено: Дмитрий(The_Prist) Щербаков  - 25 Фев 2020 18:05:41
Вот , может, непрофессионально выбрал E и F для вставки как - 250.

Сейчас почти всё идеально.
Только как вернуть , чтобы из каждого файла в папке сами таблицы копировались и вставлялись??
Сейчас только из первого файла и последнего файла в папке вставляются.
Код
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
 
Цитата
OlegMTS написал:
Сейчас только из первого файла и последнего файла в папке вставляются
предположу, что это не так. Скорее всего проблема опять в том, что Вы как-то не так поправили диапазоны и не совсем там вставляете лишние строки. Вот такой код должен вроде делать то, что нужно(кстати, изменил в нем получение файла без расширения на корректный вариант):
Код
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 dirObj = mergeObj.Getfolder("C:\Users\Дмитрий\Desktop\Новая папка\")
    Set filesObj = dirObj.Files
    For Each everyObj In filesObj
        Set bookList = Workbooks.Open(everyObj)
        'вместо "A2" указывается адрес ячейки в каждом файле, с которой начинать сборку
        'например, "B3:IV" объединит все данные из файлов, начиная с ячейки B3
        With bookList.Sheets(1)
            Set rr = .Range("A4:D" & Cells(.Rows.Count, 1).End(xlUp).Row)
        End With
        'Здесь столбец не менять
        With ThisWorkbook.Worksheets(1)
            llastr = .Cells(.Rows.Count, 1).End(xlUp).Row
            rr.Copy .Range("A" & llastr + 1)
            'имя файла
            .Cells(llastr + 1, rr.Columns.Count + 1).Resize(rr.Rows.Count).Value = mergeObj.GetBaseName(everyObj)
            'значение из ячейки D1(правда, непонятно из какого листа - поэтому из 1)
            .Cells(llastr + 1, rr.Columns.Count + 2).Resize(rr.Rows.Count).Value = bookList.Sheets(1).Range("D1").Value
        End With
        bookList.Close 0
    Next
End Sub
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
OlegMTS, разрешите поинтересоваться? А принципиально макросом? Можно еще так, например.
Вот горшок пустой, он предмет простой...
 
Цитата
PooHkrd написал:
А принципиально макросом?
Да,очень желательно. Хотя главное конечно,сокращение времени в дальнейшем. Спасибо.
Вчера ,точнее к утру выкрутился таким образом , что поскольку названия файлов -это года ,которые есть в собираемых таблицах, использовал формулы ГОД() и потом сцепить() .

Ругать можно)) записывал как видно рекодером и то не очень корректно, успокаивал себя тем, что главное работает)
Код
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
 
Цитата
Дмитрий(The_Prist) Щербаков написал:
предположу, что это не так
Да, как-то я , наверно,в кодировании трудно улавливаю связь между тем что на экране и что к этому привело точно. Тороплюсь с выводом о том, в чем именно ошибка.А надо смотреть глубже,пошагово как код срабатывает.

Цитата
Вот такой код должен вроде делать то, что нужно
да,спасибо. этот вариант идеально собирает и прописывает названия и дату из D1

Хотя и больше 5 лет уже с Эксель, но всё равно вижу, как это решение получается какое-то волшебное)
Хоть бы чаша моего ожидания выучить в совершенстве VBA переполнилась с этой каплей!!
Страницы: 1
Наверх