Консолидация нескольких файлов в один

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Консолидация нескольких файлов в один (Макросы/Sub)

l-lisa

Дата: Четверг, 12.03.2015, 18:21 | Сообщение № 1

Группа: Проверенные

Ранг: Обитатель

Сообщений: 312

Репутация: 1 ±

Замечаний: 0% ±

Excel 2010

Здравствуйте, у меня есть несколько(150) файлов с одинаковой шапкой, мне нужно чтобы все строки с каждого отдельного файла копировались в один общий. Пример во вложении: первая строка содержит заголовок, он в каждом файле одинаковый. Ниже строки с данными которые нужно объединять, то есть, из каждого файла брать строки и добавлять их одна под другую. В каждом файле примерно 2-4 строки. Файлы с расширением .csv/ Во вложении у меня макрос, но он объединяет данные только с листов одного файла, а как сделать для множества файлов сsv я не знаю...Подскажите, пожалуйста!

К сообщению приложен файл: 5759162.xlsx (9.3 Kb)

Ответить

DJ_Marker_MC

Дата: Четверг, 12.03.2015, 18:52 | Сообщение № 2

Группа: Друзья

Ранг: Ветеран

Сообщений: 991

Репутация: 213 ±

Замечаний: 0% ±

Excel 2019

l-lisa, Добрый день. Мне уже пора убегать с работы, но по описанию очень схоже с одним из моих файлов. Если в макросах немножко ориентируетесь то посмотрите, может разберетесь.

[vba]

Код

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

'открываем все книги в папке рабочие (там храним файлы от регионов)
Dim MyName As String
Dim MyPath As String
Dim sPath As String ' тут вставил
      MyPath = "D:\Мои документы\01 - Отчеты и Анализы\01 - План-Факт\План\План по менеджерам\РЕГИОНЫ\"
      MyName = Dir(MyPath & "*.xlsx")
       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
'            wb.Activate
              LR = wb.Worksheets(1).Cells(17, 1).End(xlUp).Row

              wb.Worksheets(1).Unprotect ("000")
              With wb.Worksheets(1).Range("A3:O" & LR) 'во всем коде нужно поменять лишь в этой строке последний столбец в зависимости от к-во тов.групп.
              .Copy
              .PasteSpecial Paste:=xlPasteValues
              .Copy
              End With

'            wb.Worksheets(1).Range("A3:S" & LR).Copy
              Workbooks(q).Worksheets(1).Cells(LastRow, 1).PasteSpecial xlPasteAll

              With Selection
                  .HorizontalAlignment = xlCenter
                  .Font.Bold = True
                  .Font.Italic = False
                  .Font.Size = 10
                  .Font.Name = "Calibri"
              End With
              wb.Close
          End If
      Next
[A1].Activate
Application.CutCopyMode = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

[/vba]

в этой строке нужно указать путь где лежат Ваши файлы (те которых 150 штук)
[vba]

Код

MyPath = "D:\Мои документы\01 - Отчеты и Анализы\01 - План-Факт\План\План по менеджерам\РЕГИОНЫ\"

[/vba]
Основной файл не должен быть в этой папке

Код

[/vba]

в этой строке нужно указать путь где лежат Ваши файлы (те которых 150 штук)
[vba]

Код

MyPath = "D:\Мои документы\01 - Отчеты и Анализы\01 - План-Факт\План\План по менеджерам\РЕГИОНЫ\"

[/vba]
Основной файл не должен быть в этой папкеDJ_Marker_MC

Ответить

Сообщениеl-lisa, Добрый день. Мне уже пора убегать с работы, но по описанию очень схоже с одним из моих файлов. Если в макросах немножко ориентируетесь то посмотрите, может разберетесь.

[vba]

Код

[/vba]

в этой строке нужно указать путь где лежат Ваши файлы (те которых 150 штук)
[vba]

Код

MyPath = "D:\Мои документы\01 - Отчеты и Анализы\01 - План-Факт\План\План по менеджерам\РЕГИОНЫ\"

[/vba]
Основной файл не должен быть в этой папке

Автор - DJ_Marker_MC
Дата добавления - 12.03.2015 в 18:52

l-lisa

Дата: Четверг, 12.03.2015, 19:00 | Сообщение № 3

Группа: Проверенные

Ранг: Обитатель

Сообщений: 312

Репутация: 1 ±

Замечаний: 0% ±

Excel 2010

DJ_Marker_MC спасибо, но не срабатывает у меня макрос...

Ответить

DJ_Marker_MC

Дата: Четверг, 12.03.2015, 23:50 | Сообщение № 4

Группа: Друзья

Ранг: Ветеран

Сообщений: 991

Репутация: 213 ±

Замечаний: 0% ±

Excel 2019

l-lisa, приложите свой один общий файл и один свой типичный csv
хотя думаю, что не срабатывает из-за этого:
[vba]

Код

MyName = Dir(MyPath & "*.xlsx")

[/vba]
но все же, приложите свой csv и общий, посмотрим как себя поведет макрос

Ответить

l-lisa

Дата: Пятница, 13.03.2015, 07:37 | Сообщение № 5

Группа: Проверенные

Ранг: Обитатель

Сообщений: 312

Репутация: 1 ±

Замечаний: 0% ±

Excel 2010

Один общий файл-это просто пустой файл эксель, в который скопируется один раз шапка(одна и та же во всех файлах, а под неё будут вставляться последовательно строки из остальных файлов

К сообщению приложен файл: 8326878.csv (1.4 Kb) · 4061626.csv (13.2 Kb)

Ответить

l-lisa

Дата: Пятница, 13.03.2015, 07:51 | Сообщение № 6

Группа: Проверенные

Ранг: Обитатель

Сообщений: 312

Репутация: 1 ±

Замечаний: 0% ±

Excel 2010

общий - содержит шапку(заголовки в каждом отдельном столбце)

К сообщению приложен файл: 8027966.xlsx (8.9 Kb)

Ответить

DJ_Marker_MC

Дата: Воскресенье, 15.03.2015, 20:55 | Сообщение № 7

Группа: Друзья

Ранг: Ветеран

Сообщений: 991

Репутация: 213 ±

Замечаний: 0% ±

Excel 2019

l-lisa, Добрый вечер. Только добрался до темы.
Пробуйте:
[vba]

Код

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

'открываем все книги в папке рабочие (там храним файлы от регионов)
Dim MyName As String
Dim MyPath As String
Dim sPath As String ' тут вставил
     MyPath = "D:\Desktop\тест\файлы\"
     MyName = Dir(MyPath & "*.csv")
     Do While MyName <> ""
         sPath = MyPath + MyName ' тут вставил

Workbooks.Open sPath, True
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=False

         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
             wb.Activate
             LR = Cells(Rows.Count, 1).End(xlUp).Row

             With wb.Worksheets(1).Range("A2:T" & LR) 'во всем коде нужно поменять лишь в этой строке последний столбец в зависимости от к-во тов.групп.
             .Copy
             .PasteSpecial Paste:=xlPasteValues
             .Copy
             End With

             Workbooks(q).Worksheets(1).Cells(LastRow, 1).PasteSpecial xlPasteAll

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

[/vba]

Вот тут:
[vba]

Код

MyPath = "D:\Desktop\тест\файлы\"

[/vba]
Укажите путь к папке с вашими csv

Файлик с макросом и кнопкой Start - в приложении.

l-lisa, Добрый вечер. Только добрался до темы.
Пробуйте:
[vba]

Код

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

'открываем все книги в папке рабочие (там храним файлы от регионов)
Dim MyName As String
Dim MyPath As String
Dim sPath As String ' тут вставил
     MyPath = "D:\Desktop\тест\файлы\"
     MyName = Dir(MyPath & "*.csv")
     Do While MyName <> ""
         sPath = MyPath + MyName ' тут вставил

Workbooks.Open sPath, True
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=False

         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
             wb.Activate
             LR = Cells(Rows.Count, 1).End(xlUp).Row

             With wb.Worksheets(1).Range("A2:T" & LR) 'во всем коде нужно поменять лишь в этой строке последний столбец в зависимости от к-во тов.групп.
             .Copy
             .PasteSpecial Paste:=xlPasteValues
             .Copy
             End With

             Workbooks(q).Worksheets(1).Cells(LastRow, 1).PasteSpecial xlPasteAll

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

[/vba]

Вот тут:
[vba]

Код

MyPath = "D:\Desktop\тест\файлы\"

[/vba]
Укажите путь к папке с вашими csv

Файлик с макросом и кнопкой Start - в приложении.DJ_Marker_MC

К сообщению приложен файл: Test.xlsm (21.4 Kb)

Ответить

Сообщениеl-lisa, Добрый вечер. Только добрался до темы.
Пробуйте:
[vba]

Код

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

'открываем все книги в папке рабочие (там храним файлы от регионов)
Dim MyName As String
Dim MyPath As String
Dim sPath As String ' тут вставил
     MyPath = "D:\Desktop\тест\файлы\"
     MyName = Dir(MyPath & "*.csv")
     Do While MyName <> ""
         sPath = MyPath + MyName ' тут вставил

Workbooks.Open sPath, True
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=False

         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
             wb.Activate
             LR = Cells(Rows.Count, 1).End(xlUp).Row

             With wb.Worksheets(1).Range("A2:T" & LR) 'во всем коде нужно поменять лишь в этой строке последний столбец в зависимости от к-во тов.групп.
             .Copy
             .PasteSpecial Paste:=xlPasteValues
             .Copy
             End With

             Workbooks(q).Worksheets(1).Cells(LastRow, 1).PasteSpecial xlPasteAll

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

[/vba]

Вот тут:
[vba]

Код

MyPath = "D:\Desktop\тест\файлы\"

[/vba]
Укажите путь к папке с вашими csv

Файлик с макросом и кнопкой Start - в приложении.

Автор - DJ_Marker_MC
Дата добавления - 15.03.2015 в 20:55

l-lisa

Дата: Воскресенье, 15.03.2015, 22:21 | Сообщение № 8

Группа: Проверенные

Ранг: Обитатель

Сообщений: 312

Репутация: 1 ±

Замечаний: 0% ±

Excel 2010