Как собрать данные с нескольких листов или книг?
Очень часто бывает необходимо собрать данные с нескольких листов одной книги или даже с листов нескольких книг. Например, каждую неделю мы получаем некие отчеты от отделов, которые необходимо собрать в одну общую таблицу для построения сводной таблицы. Или это могут быть некие книги прайсов по товарам от разных поставщиком, который опять же надо сначала объединить, а потом уже анализировать. Вручную делать это довольно муторно. И то, муторно это только для первых 20-ти листов/файлов, потом становится просто тошно. Поэтому решил поделиться решением, которое поможет собрать данные со всех листов книги, со всех листов всех указанных книг или только с указанных листов:
'--------------------------------------------------------------------------------------- ' Author : Щербаков Дмитрий(The_Prist) ' Профессиональная разработка приложений для MS Office любой сложности ' Проведение тренингов по MS Excel ' https://www.excel-vba.ru ' info@excel-vba.ru ' WebMoney - R298726502453; Яндекс.Деньги - 41001332272872 ' Purpose: http://www.excel-vba.ru/chto-umeet-excel/kak-sobrat-dannye-s-neskolkix-listov-ili-knig/ ' Процедура сбора данных с нескольки листов/книг '--------------------------------------------------------------------------------------- Option Explicit Sub Consolidated_Range_of_Books_and_Sheets() Dim iBeginRange As Range, rCopy As Range, lCalc As Long, lCol As Long Dim oAwb As String, sCopyAddress As String, sSheetName As String Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer Dim wsSh As Worksheet, wsDataSheet As Worksheet, bPolyBooks As Boolean, avFiles Dim wbAct As Workbook Dim bPasteValues As Boolean, IsPasteSheetName As Boolean On Error Resume Next 'Выбираем диапазон выборки с книг Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _ "1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _ vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8) 'для указания диапазона без диалогового окна: 'Set iBeginRange = Range("A1:A10") 'диапазон указывается нужный 'Если диапазон не выбран - завершаем процедуру If iBeginRange Is Nothing Then Exit Sub End If 'Указываем имя листа 'Допустимо указывать в имени листа символы подставки ? и *. 'Если указать только * то данные будут собираться со всех листов sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр") 'Если имя листа не указано - данные будут собраны со вех листов If sSheetName = "" Then sSheetName = "*" End If 'добавлять ли имя листа в начало таблицы IsPasteSheetName = (MsgBox("Вставлять имя листа первым столбцом?", vbQuestion + vbYesNo, "www.wxcel-vba.ru") = vbYes) On Error GoTo 0 'Запрос - вставлять на результирующий лист все данные 'или только значения ячеек (без формул и форматов) bPasteValues = (MsgBox("Вставлять только значения?", vbQuestion + vbYesNo, "www.wxcel-vba.ru") = vbYes) 'Запрос сбора данных с книг(если Нет - то сбор идет с активной книги) If MsgBox("Собрать данные с нескольких книг?", vbInformation + vbYesNo, "www.wxcel-vba.ru") = vbYes Then avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True) If VarType(avFiles) = vbBoolean Then Exit Sub bPolyBooks = True lCol = 1 Else avFiles = Array(ThisWorkbook.FullName) End If If IsPasteSheetName Then lCol = lCol + 1 End If 'отключаем обновление экрана, автопересчет формул и отслеживание событий 'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды With Application lCalc = .Calculation .ScreenUpdating = False .EnableEvents = False .Calculation = xlManual End With 'создаем новый лист в книге для сбора Set wsDataSheet = ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)) 'если нужно сделать сбор данных на новый лист книги с кодом 'Set wsDataSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) 'цикл по книгам For li = LBound(avFiles) To UBound(avFiles) If bPolyBooks Then Set wbAct = Workbooks.Open(Filename:=avFiles(li)) Else Set wbAct = ThisWorkbook End If oAwb = wbAct.Name 'цикл по листам For Each wsSh In wbAct.Sheets If wsSh.Name Like sSheetName Then 'Если имя листа совпадает с именем листа, в который собираем данные 'и сбор идет только с активной книги - то переходим к следующему листу If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_ With wsSh Select Case iBeginRange.Count Case 1 'собираем данные начиная с указанной ячейки и до конца данных lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row iLastColumn = .Cells.SpecialCells(xlLastCell).Column sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address Case Else 'собираем данные с фиксированного диапазона sCopyAddress = iBeginRange.Address End Select lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1 'определяем для копирования диапазон только заполненных данных на листе Set rCopy = Intersect(.Range(sCopyAddress).Parent.UsedRange, .Range(sCopyAddress)) 'вставляем имя книги, с которой собраны данные If lCol > 0 Then If bPolyBooks Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(rCopy.Rows.Count).Value = oAwb End If If IsPasteSheetName Then wsDataSheet.Cells(lLastRowMyBook, lCol).Resize(rCopy.Rows.Count).Value = .Name End If End If 'если вставляем только значения If bPasteValues Then rCopy.Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteValues wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteFormats Else 'если вставляем все данные ячеек(формулы, форматы и т.д.) rCopy.Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol) End If End With End If NEXT_: Next wsSh If bPolyBooks Then wbAct.Close False End If Next li With Application .ScreenUpdating = True .EnableEvents = True .Calculation = lCalc End With End Sub |
Приведенный выше код необходимо вставить в стандартный модуль(Что такое модуль? Какие бывают модули?). Выполнить его можно будет из этой книги нажатием клавиш Alt+F8. В появившемся окне выбрать
После вызова макроса поочередно будут появляется запросы, в которых надо будет указать исходные параметры:
Диапазон сбора данных - Если в окне выбора диапазона выбрать только одну ячейку, то данные будут собраны со всех листов книги/книг, начиная с этой ячейки и до последней ячейки листа.
Если выбрать несколько ячеек, данные будут собраны только с указанного диапазона всех листов книги/книг. Допускается указать несвязанный(рваный) диапазон(например, только три столбца: ). Сделать это можно, выделив нужный диапазон с зажатой клавишейA:A ,D:D ,F:F Ctrl . Здесь необходимо учитывать, что Excel позволяет одним махом скопировать не любые рваные диапазоны, а только диапазоны одного размера и только если они начинаются с одной строки. Например, если выделить диапазоны - они будут скопированы без проблем. Но если попробовать указать диапазоны со сдвигом:A1:B20 ,F1:H20 - Excel выдаст ошибку.A1:B20 ,F2:H21 Имя листа - Необязателен для указания. Если не указан - данные будут собраны со всех листов. Указать можно как точное соответствие имени листа, так и с частичным соответствием. Например, если в книгах для сбора данных необходимо собрать данные только с листа "Январь", то следует так и указать - "Январь". Если требуется собрать данные только с листов, начинающихся с "Продажи"("Продажи ЮГ", "Продажи НН", "Продажи Запад" и т.д.), то следует применить символ подстановки звездочку - "Продажи*". Если надо собрать с листов, содержащих в имени "продажи"("Итоговые продажи ЮГ", "Продажи НН", "Сезонные продажи" и т.д.), то указываем "*продажи*". Если надо собрать только с листа "Сезонные продажи", но известно, что вместо пробела может быть нижнее подчеркивание или тире("Сезонные продажи", "Сезонные_продажи", "Сезонные-продажи") или иной символ, то можно также применить звездочку - "Сезонные*продажи". Но если среди листов могут встречаться и такие как "Сезонные разовые продажи", "Сезонные корпоративные продажи" и т.п., но информацию с них собирать не надо, то можно применить вопросительный знак - "Сезонные?продажи". Вопросительный знак заменяет любой один символ, звездочка - любое количество любых символов.Вставлять имя листа первым столбцом? - если выбрать Да, перед данными в итоговой таблице будут записаны имена листов, с которых были собраны данные. Если будет указано собирать данные с нескольких книг - то имя листа будет во втором столбце, если с листов одной книги - то имя листа будет первым столбцом.Вставлять только значения? - если выбрать Да, то в результирующий лист с листов будут вставлены исключительно значения ячеек (без формул), но при этом сохранятся их форматы(формат чисел, цвет заливки, цвет шрифта, границы и т.п.). Может пригодится, если на листах для сбора записаны формулы, ссылающиеся на другие листы, книги, диапазоны. При обычном копировании может случиться так, что формула выдаст ошибку, т.к. в книге для вставки нет таких листов и диапазонов или данные расположены иначе. Если выбрать Нет, то все ячейки с листов на результирующий будут копироваться в точности как в исходных листах.- И последний запрос:
Собрать данные с нескольких книг? - если выбрать Да, то появится диалоговое окно выбора файлов. Надо указать все файлы, данные с которых необходимо собрать. Если выбрать Нет, то данные будут собираться с листов только активной книги. При этом, если выбран вариант сбора с нескольких книг, то первым столбцом в итоговой таблице будут записаны имена файлов, с которых были собраны данные
Данные будут собраны на новый лист книги с макросом. Если данные собирались с нескольких книг, то в первый столбец будут занесены имена книг, с которых собраны данные.
Если после сбора данных обнаружили, что после каждого файла/листа много пустых строк, то следует найти в коде строку:
lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row |
и заменить её на строку примерно следующего содержания:
lLastrow = .Cells(.Rows.Count, 1).End(xlUp).Row |
Актуально это для файлов с одинаковой структурой. Например, если сбор идет с листов по продажам, то вполне может быть такое, что в столбце 1 может не быть данных. Поэтому следует определить номер столбца, в котором наполнение данных максимально. Например, это может быть столбец с наименованиями товара или с суммами. Если это столбец D, то следует строку записать так:
lLastrow = .Cells(.Rows.Count, 4).End(xlUp).Row 'ищем последнюю строку в 4-м столбце |
Важное замечание: Если вы используете Excel 2007 и выше и файлы для сбора данных тоже в этом формате, то следует скачанный файл сначала сохранить в формат "Книга Excel с поддержкой макросов(.xlsm)", закрыть и открыть заново. Иначе есть шанс получить ошибку при сборе данных, т.к. Excel будет в режиме совместимости и не сможет поместить на результирующий лист более 65536 строк.
Сбор данных с листов и книг.xls (73,0 KiB, 37 833 скачиваний)
Также см.:
Сбор данных с нескольких листов/книг
Как объединить несколько текстовых файлов в один?
Просмотреть все файлы в папке
План-фактный анализ в Excel при помощи Power Query
Статья помогла? Поделись ссылкой с друзьями!
Поиск по меткам
Access apple watch Multex Power Query и Power BI VBA управление кодами Бесплатные надстройки Дата и время Записки ИП Надстройки Печать Политика Конфиденциальности Почта Программы Работа с приложениями Разработка приложений Росстат Тренинги и вебинары Финансовые Форматирование Функции Excel акции MulTEx ссылки статистикаКомментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум
Добрый день, скажите пожалуйста, данные у меня собраны так -http://joxi.ru/BA01zBBtBOg7ar
Возможно ли добавить название столбцов, и фильтр
Вы элементарно можете записать рекордером код копирования заголовков и установки фильтра. В этом нет ничего сложного.
Здравствуйте, Дмитрий!https://1drv.ms/i/s!AhFACJaqXOEEgoxd8KR-BkJ-pHRAFQ ), которая появляется после вставки из 8-ми первых кних. Книгу для вставки сохранял и в .xlsx и .xlsm - не помогло. Исходные файлы в формате .xls, по одному листу в каждой книге с идентичной структурой и размером данных A1:T101. т.е. конечный результат должен иметь 47500 строк данных, а работа скрипта заканчивается на 800...
Решил воспользоваться Вашим макросом для копирования даных из 475 книг на один лист, но столкнулся с ошибкой VB Run-time eror '1004' (скрин ошибки
Помогите разобратся, пожалуйста!
Алексей, а Вы не заметили, что текст ошибки пишет? Ровно то, что книгу не получается открыть. Т.е. метод Open просто не срабатывает. Посмотрите на какой книге останавливается код и изучите книгу. Возможно, она повреждена и не может быть открыта в режиме чтения/записи.
Здравствуйте, подскажите пожалуйста, а как собрать данные с защищенных листов, пароль к которым я не знаю
Только через MulTEx:Сбор данных с листов/книг
Спасибо за полезную статью! Очень пригодилось!
Возможно кому пригодится, изменил код. Суть в том, что есть накладные с утвержденной формой. Накладные с разных объектов, которые нужно собрать в одну книгу. Причем, каждое направление(0,1,2,3) на разные вкладки(имя вкладки меняется ручками.
'---------------------------------------------------------------------------------------
' Module : mConsolidated
' DateTime : 02.02.2010 17:06
' Author : The_Prist(Щербаков Дмитрий)
' Purpose : http://www.excel-vba.ru/chto-umeet-excel/kak-sobrat-dannye-s-neskolkix-listov-ili-knig/
' Процедура сбора данных с нескольки листов/книг
'---------------------------------------------------------------------------------------
Option Explicit
Sub Consolidated_Range_of_Books_and_Sheets()
Dim iBeginRange As Object, lCalc As Long, lCol As Long
Dim oAwb As String, sCopyAddress As String, sSheetName As String
Dim lLastRow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
Dim wsSh As Object, wsDataSheet As Object, bPolyBooks As Boolean, avFiles
Dim wbAct As Workbook
Dim bPasteValues As Boolean
Dim AWN As String
On Error Resume Next
'Выбираем диапазон выборки с книг
'выбрал диапазон значений таблицы(можно указать только одну ячейку тогда диапазон от этой ячеки до конца данных)
Set iBeginRange = Range("E14:P252")
'Указываем имя листа
'Допустимо указывать в имени листа символы подставки ? и *.
'Если указать только * то данные будут собираться со всех листов
sSheetName = "ТТН 1" 'указал имя листа в книге (у меня во всех книгах листы одинаковые
bPasteValues = vbYes 'вставляет только значения из дапазона
'Предлагает выбрать книги с которых нужно выбрать данные
ChDrive Left(ThisWorkbook.Path, 2)
ChDir ThisWorkbook.Path
avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
If VarType(avFiles) = vbBoolean Then Exit Sub
bPolyBooks = True
lCol = 1
'отключаем обновление экрана, автопересчет формул и отслеживание событий
'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды
With Application
lCalc = .Calculation
.ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
End With
'Указываем на какой лист в текущей книги собирать данные
Set wsDataSheet = ThisWorkbook.Sheets("0")
'цикл по книгам
For li = LBound(avFiles) To UBound(avFiles)
If bPolyBooks Then
Set wbAct = Workbooks.Open(Filename:=avFiles(li), UpdateLinks:=False)
Else
Set wbAct = ThisWorkbook
End If
oAwb = wbAct.Name
'цикл по листам
For Each wsSh In wbAct.Sheets
If wsSh.Name Like sSheetName Then
'Если имя листа совпадает с именем листа, в который собираем данные
'и сбор идет только с активной книги - то переходим к следующему листу
If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
With wsSh
Select Case iBeginRange.Count
Case 1 'собираем данные начиная с указанной ячейки и до конца данных
lLastRow = .Cells(1, 1).SpecialCells(xlLastCell).Row
iLastColumn = .Cells.SpecialCells(xlLastCell).Column
sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastRow, iLastColumn)).Address
Case Else 'собираем данные с фиксированного диапазона
sCopyAddress = iBeginRange.Address
End Select
'должен был каждый раз удалять старые значения и копировать по новой но не работает
lLastRowMyBook = wsDataSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
'удаляем мия файла книг оставляя только первое занчение
AWN = ActiveWorkbook.Name
AWN = Mid(AWN, 1, 1)
'вставляем имя книги, с которой собраны данные
If lCol Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(Range(sCopyAddress).Rows.Count).Value = AWN
If bPasteValues Then 'если вставляем только значения
.Range(sCopyAddress).Copy
wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteValues
Else
.Range(sCopyAddress).Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol)
End If
End With
End If
NEXT_:
Next wsSh
If bPolyBooks Then Application.CutCopyMode = False: wbAct.Close False 'не будет запроса от буфера обмена на большое количество данных в нем
Next li
With Application
.ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc
End With
'Удаление строк
Dim sSubStr As String 'искомое слово или фраза(может быть указанием на ячейку)
Dim lMet As Long
Dim arr
sSubStr = "" 'искомое выражение в ячейке которое нужно удалить
lCol = 12 'столбец в котором нужно искать значение(в книге куда были скопированы данные)
lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
arr = Cells(1, lCol).Resize(lLastRow).Value
Application.ScreenUpdating = 0
Dim rr As Range
For li = 1 To lLastRow
If -(InStr(arr(li, 1), sSubStr) > 0) = lMet Then
If rr Is Nothing Then
Set rr = Cells(li, 1)
Else
Set rr = Union(rr, Cells(li, 1))
End If
End If
Next li
If Not rr Is Nothing Then rr.EntireRow.Delete
Application.ScreenUpdating = 1
End Sub
Вопросы на засыпку: все таки не происходит замены старых данных на новые при повторе макроса(сначала был потом пропал-мистика); как сделать запрос "Выберите направление 0,1,2,3" и чтобы введенное значение изменяло в программе имя листа на который будут скопированы данные.
Роман, почитайте комментарии. Чтобы сбор данных происходил с заменой надо как минимум лист для сбора очищать от прежних данных. У Вас этого нет. Сделайте что-то вроде:
вставить это надо вместо этого:
Рабочий вариант:
а на счет кнопки есть мысли? В каком направлении хотя бы смотреть...
Дмитрий, огромное Вам спасибо за макрос и за все ваши статьи и материалы! Очень полезно в работе. С помощью данного макроса сократила время выполнения своей задачи с 8 часов до получаса.
Дмитрий, доброго времени суток!
Подскажите, пожалуйста, все комментарии прочтены и учтены :)
Беру Ваш код, немного его исправила по Вашим комментариям.
Но только у меня проблема, видимо что то делаю не так(
У меня есть три файла, нужно их свести, формат таблицы одинаковый, но только файлы разные, у кого то "простыня", а есть и совсем не много данных. Проблема: при первом варианте у меня все внизу собирается, но опять же с пустыми стоками между данными файлов, при втором варианте своди ровненько и красиво, без пустых строк, но почему то он переносит только последний файл (т.е. 1 из 3)Заранее благодарю за помощь!
lLastrow = .Cells(.Rows.Count, 7).End(xlUp).Row
уверены, что искать последнюю ячейку необходимо именно в 7-м столбце(G)?
Плюс в этой строке ошибка:
lLastRowMyBook = wsDataSheet.Cells.End(xlUp).Row + 4
где Вы последнюю ячейку вычисляете? В каком столбце? По факту в данном случае эта строка всегда 5 будет возвращать...
Дмитрий, добрый день!
Спасибо за ответ!
Все верно, мне нужно смотреть по 7 столбцу, так как в 6 столбце есть формула, которая соединяет несколько ячеек и между значениями знак знак "-", соответственно даже когда формула ничего не соединяет у меня простыня из знаков " _-_"
lLastRowMyBook = wsDataSheet.Cells.End(xlUp).Row + 4
данное условие, как я понимаю, как раз начинает выводить информацию в 5 строку, так как "шапка" таблицы всегда одинаковая.Извините, не поняла, в чем ошибка?
Заранее спасибо!
Юлия, ну хоть логику включите элементарную :)
lLastRowMyBook = wsDataSheet.Cells(wsDataSheet.Rows.count,7) .End(xlUp).Row
Сравните то, как Вы ищете последнюю строку в книгах и как в книге для сбора.
Т.е. по сути у Вас данные каждой книги сейчас вставляются начиная с 5-ой строки. А должны в зависимости от данных вставляться - с просмотром заполненных данные в 7-м столбце.
Что-то вроде:
if lLastRowMyBook = 1 then lLastRowMyBook = 5 'если данных на листе еще нет - с 5-ой строки
Благодарю! спасибо вам огромное!!! все получилось!!! хорошего Вам дня :)
Здравствуйте, Дмитрий! Спасибо за Ваш труд. Макрос работает прекрасно, нареканий нет. У меня есть два вопроса(в комментариях искал ответ на свои вопросы, но не нашел) :
1) макрос вставляет помимо информации еще и название файла excel, к примеру : "20.10_Компания N.xls" . Можно сделать так , чтобы он не вставлял названия файлов?
2)Данный вопрос очень наглый с моей стороны, буду очень признателен, если на него тоже ответите : у меня макрос копирует таблицу из 4 строк в которых данные и вставляет их также в 4 строки,как и копировал. Можно ли сделать так, чтобы макрос вставлял копированные данные сразу в одну ячейку и так далее, то есть скопировал из первой книги данные и вставил в ячейку,потом данные из второй книги в соседнюю ячейку и т.д. ?
Федор, по первому:
достаточно перед строкой с комментарием:
'цикл по книгам
вставить следующую строку:
lCol = 0
По второму: слишком много дорабатывать надо, чтобы это реализовать в данном коде.
Подскажите, пожалуйста, а как тогда с помощью данного макроса вывести из определенных книг все строки в ячейке которых содержится к примеру определенное название товара (допустим Товар1). Т.е. в книгах порядок столбцов может быть разным, но наименование товара есть и нужно вывести всю строку...
Никита, напрямую в этом коде не получится. Для подобного код надо переписывать. Подобная возможность есть в MulTEx:Сбор данных с нескольких листов/книг
Спасибо, попробую. А пробной версии достаточно будет или нужна полная?
Для попробовать и пробной версии достаточно. Она полнофункциональна в течении месяца.
Ок, спасибо.
День добрый!
Прошу помочь с написанием макроса для следующих задач.
Написать марос, который собирает листы "акция" из всех файлов текущей папки в данный файл.
Каждый собранный лист должен носить название книги, из которой он взят.
С помощью макроса заполнить таблицу на листе "Сводная", в которую должны войти данные из всех собранных листов: "Москва", " Самара", Краснодар" и "Ростов"