Как собрать данные с нескольких листов или книг?
Очень часто бывает необходимо собрать данные с нескольких листов одной книги или даже с листов нескольких книг. Например, каждую неделю мы получаем некие отчеты от отделов, которые необходимо собрать в одну общую таблицу для построения сводной таблицы. Или это могут быть некие книги прайсов по товарам от разных поставщиком, который опять же надо сначала объединить, а потом уже анализировать. Вручную делать это довольно муторно. И то, муторно это только для первых 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 ссылки статистикаКомментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум
Добрый день! Скачал файл, запустил макрос, но возникла ошибка макроса на функции oAwb = wbAct.Name
Константин, спасибо. Недавно чуть изменил код и пропустил пару строк. Файл перезалил, код в статье поправил. Так что можете скачать заново и попробовать.
Ошибка скорее всего возникала при попытке сбора данных с текущей книги.
Дмитрий, спасибо!
Все верно, ошибка возникала при сборе данных
Спасибо за информацию, размещенную на сайте. Макрос по сбору данных очень выручил.
Очень кропотливо проделанная работа!
Добавлю для тех кто хочет не изменять название обработанных листов
sSheetName = "Лист1"
Спасибо.
Макрос собирает из разных книг либо все либо заданные листы в один лист текущей книги. Как сделать так чтобы макрос собирал из разных книг все листы с именем "1" на лист с именем "1" текущей книги, листы с именем "2" на лист "2" текущей книги.
Надо переписывать код. В таком виде заменой одной строки кода так сделать не получится.
Спасибо, будем думать дальше
Дмитрий, нашёл проблему макроса:
макрос отлично работает когда задается не одна ячейка а несколько, но если указать только одну ячейку, то вылетает ошибка на строке сразу при первом проходе цикла:
lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row
сам вожусь чтобы перебирать по одной ячейке путём перебора определённого массива.
Ругается на защищенность бланка листа.
Когда задаешь диапазон ячеек - всё нормально, читает и защищенные листы. пока копаюсь.
Дело не в количестве указанных ячеек, а в том, что SpecialCells не работает на защищенных листах. Поэтому и получаете ошибку. Либо защиту снимайте, либо используйте UsedRannge:
Дмитрий спасибо! Работает. Есть особенности, но терпимо.
Что нужно поправить в коде что бы на каждый файл был свой столбец, а имена файлов лишь в одной строке в начале столбца? Из 10 тысяч файлов один столбу в 2 тысячи строк в одном столбце итоги не сведешь.
Подскажите, я немного поменял код и у меня теперь вставляются данные не в первую строчку, а в 74 693 строчку, что нужно сделать, чтобы данные вставлялись в первую строку? Я только лишь поменял порядок, убрал некоторые диалоговые окна и вставлял данные не на нровый лист, а на лист "Все данные".
Сергей, Вы что-то поменяли и мне теперь предлагаете угадать что такого Вы там еще сделали, из-за чего теперь проблема? Даже код не выложили. Предположение только одно: Вы убрали создание нового листа и просто добавили очистку одного листа и на него же сбор данных осуществляете. В этом случае последнюю ячейку надо иначе определять. Почитайте комментарии - уже разбиралась такая ситуация.
Извиняюсь, поторопился
Сергей, я уже написал выше предполагаемую причину - можно почитать комментарии, ответ уже был на подобную ситуацию. Вы собираете данные на фиксированный лист и диапазоны фиксированные, что меняет подход по определению последней ячейки листа. Старайтесь хоть по подсказкам ответ искать самостоятельно.
lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row
lLastrow = .Cells(.Rows.Count, 1).End(xlup).Row
lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
Строку
замените на нечто вроде
Тоже самое и со строкой:
Почитайте на сайте статью про определение последней ячейки через VBA - тогда поймете что происходит. А для столбца последнего можно вообще фиксированное значение задать, раз диапазон сбора фиксированный.
спасибо большое,все получилось!
Дмитрий, добрый день!
Отличный макрос. Спасибо!
Все работает. У меня один вопрос.. у меня при объединении книг (по умолчанию проставила что всегда данные необходимо собирать начиная с ячейки $A$4) все работает корректно.. но собранные данные всегда начинают вставляться на новый лист начиная со второй строки.. как-то можно зафиксировать чтобы собранные данные всегда собирались начиная так же с фикисированной ячейки $A$4 ? Перечитала все комментарии но не смогла понять как мне изменить код(
Елена, добавьте перед этой стройкой:
такую:
Огромное спасибо за макрос. Подскажите пожалуйста, как его доработать, а именно: брать файлы не только из выбранной папки но и из ее под папок?
Нашел функцию FilenamesCollection заменил часть кода
с
avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
на
avFiles = FilenamesCollection("C:\Users\Кирилл\Desktop\ЭА\-\", ".xls*", 4)
но не выходит.