Очень часто бывает необходимо собрать данные с нескольких листов одной книги или даже с листов нескольких книг. Например, каждую неделю мы получаем некие отчеты от отделов, которые необходимо собрать в одну общую таблицу для построения сводной таблицы. Или это могут быть некие книги прайсов по товарам от разных поставщиком, который опять же надо сначала объединить, а потом уже анализировать. Вручную делать это довольно муторно. И то, муторно это только для первых 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. В появившемся окне выбрать Consolidated_Range_of_Books_and_Sheets и нажать Выполнить. Так же можно создать на листе кнопку и назначить ей данный макрос. Так же, если впервые работаете с макросами настоятельно рекомендую прочитать статью: Что такое макрос и где его искать?, а так же Почему не работает макрос?

После вызова макроса поочередно будут появляется запросы, в которых надо будет указать исходные параметры:

  • Диапазон сбора данных - Если в окне выбора диапазона выбрать только одну ячейку, то данные будут собраны со всех листов книги/книг, начиная с этой ячейки и до последней ячейки листа.
    Если выбрать несколько ячеек, данные будут собраны только с указанного диапазона всех листов книги/книг. Допускается указать несвязанный(рваный) диапазон(например, только три столбца: A:A,D:D,F:F). Сделать это можно, выделив нужный диапазон с зажатой клавишей Ctrl. Здесь необходимо учитывать, что Excel позволяет одним махом скопировать не любые рваные диапазоны, а только диапазоны одного размера и только если они начинаются с одной строки. Например, если выделить диапазоны A1:B20, F1:H20 - они будут скопированы без проблем. Но если попробовать указать диапазоны со сдвигом: A1:B20, F2:H21 - Excel выдаст ошибку.
  • Имя листа - Необязателен для указания. Если не указан - данные будут собраны со всех листов. Указать можно как точное соответствие имени листа, так и с частичным соответствием. Например, если в книгах для сбора данных необходимо собрать данные только с листа "Январь", то следует так и указать - "Январь". Если требуется собрать данные только с листов, начинающихся с "Продажи"("Продажи ЮГ", "Продажи НН", "Продажи Запад" и т.д.), то следует применить символ подстановки звездочку - "Продажи*". Если надо собрать с листов, содержащих в имени "продажи"("Итоговые продажи ЮГ", "Продажи НН", "Сезонные продажи" и т.д.), то указываем "*продажи*". Если надо собрать только с листа "Сезонные продажи", но известно, что вместо пробела может быть нижнее подчеркивание или тире("Сезонные продажи", "Сезонные_продажи", "Сезонные-продажи") или иной символ, то можно также применить звездочку - "Сезонные*продажи". Но если среди листов могут встречаться и такие как "Сезонные разовые продажи", "Сезонные корпоративные продажи" и т.п., но информацию с них собирать не надо, то можно применить вопросительный знак - "Сезонные?продажи". Вопросительный знак заменяет любой один символ, звездочка - любое количество любых символов.
  • Вставлять имя листа первым столбцом? - если выбрать Да, перед данными в итоговой таблице будут записаны имена листов, с которых были собраны данные. Если будет указано собирать данные с нескольких книг - то имя листа будет во втором столбце, если с листов одной книги - то имя листа будет первым столбцом.
  • Вставлять только значения? - если выбрать Да, то в результирующий лист с листов будут вставлены исключительно значения ячеек (без формул), но при этом сохранятся их форматы(формат чисел, цвет заливки, цвет шрифта, границы и т.п.). Может пригодится, если на листах для сбора записаны формулы, ссылающиеся на другие листы, книги, диапазоны. При обычном копировании может случиться так, что формула выдаст ошибку, т.к. в книге для вставки нет таких листов и диапазонов или данные расположены иначе. Если выбрать Нет, то все ячейки с листов на результирующий будут копироваться в точности как в исходных листах.
  • И последний запрос: Собрать данные с нескольких книг? - если выбрать Да, то появится диалоговое окно выбора файлов. Надо указать все файлы, данные с которых необходимо собрать. Если выбрать Нет, то данные будут собираться с листов только активной книги. При этом, если выбран вариант сбора с нескольких книг, то первым столбцом в итоговой таблице будут записаны имена файлов, с которых были собраны данные

Данные будут собраны на новый лист книги с макросом. Если данные собирались с нескольких книг, то в первый столбец будут занесены имена книг, с которых собраны данные.

Если после сбора данных обнаружили, что после каждого файла/листа много пустых строк, то следует найти в коде строку:

lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row

и заменить её на строку примерно следующего содержания:

lLastrow = .Cells(.Rows.Count, 1).End(xlUp).Row

где 1 - это номер столбца на листах данных, в котором искать последнюю заполненную ячейку.
Актуально это для файлов с одинаковой структурой. Например, если сбор идет с листов по продажам, то вполне может быть такое, что в столбце 1 может не быть данных. Поэтому следует определить номер столбца, в котором наполнение данных максимально. Например, это может быть столбец с наименованиями товара или с суммами. Если это столбец D, то следует строку записать так:

lLastrow = .Cells(.Rows.Count, 4).End(xlUp).Row 'ищем последнюю строку в 4-м столбце

Подробнее про определение последней строки можно прочитать в статье: Как определить последнюю ячейку на листе через VBA?

Важное замечание: Если вы используете Excel 2007 и выше и файлы для сбора данных тоже в этом формате, то следует скачанный файл сначала сохранить в формат "Книга Excel с поддержкой макросов(.xlsm)", закрыть и открыть заново. Иначе есть шанс получить ошибку при сборе данных, т.к. Excel будет в режиме совместимости и не сможет поместить на результирующий лист более 65536 строк.

Скачать пример:

  Сбор данных с листов и книг.xls (73,0 КиБ, 38 206 скачиваний)

Также см.:
Сбор данных с нескольких листов/книг
Как объединить несколько текстовых файлов в один?
Просмотреть все файлы в папке
План-фактный анализ в Excel при помощи Power Query

Loading

411 комментариев

  1. Дмитрий, день добрый.
    Прочитала комментарии, потыкалась, не выходит, только начала осваивать VBA.
    Подскажите, пожалуйста, если найдется время, как добавить, чтобы помимо наименования файла из определенной ячейки брались данные и заносились в столбец?
    Как сделать это вместо названия файла я поняла, а вот как сделать, чтобы было и то, и другое.. что-то пока нет.

  2. Глубокоуважаемый автор сего восхитительного макроса!
    А ответьте пожалуйста малосведущему в VBA пользователю на такой каверзный вопрос.
    Можно ли(сложно ли) прикрутить к этому алгоритму сбора данных еще и функцию выборки определенных данных(а не последовательного простого копирования указанных диапазонов)?
    Поясню что я имею.... в виду.
    Имеется книга с набором листов Графиков работы подразделений.
    Наименования листов стандартизированы макросом, создающим эти графики из образцового листа(формат Номер месяца-Год_Аббревиатура наименования подразделения).
    В графике каждой персоне отведен массив данных из 2 строк(одна строка - рабочие часы, и вторая - ночные рабочие часы) и 31 колонка(дни месяца).

    Имеется лист "Табель рабочего времени", в который, по замыслу, должны собраться данные из графиков нужного месяца, года и имени подразделения(или всех подразделений) в соотвествии с выставленными в определенных ячейках условиями выборки.
    На листе табеля имеется список имен всех работников всех подразделений.
    По замыслу, хотелось бы макросом (формулами я уже второй месяц безуспешно пытался это решить) по списку имен в Табеле (список может корректироваться по принципу выборки определенного подразделения, или определенных лиц(к примеру уходящих в отпуск или увольняющихся)) и выставленных в определенных ячейках месяце, годе и наименованию подразделения, сделать выборку данных с листов графиков работы.

    Ну как-то так, немного сумбурно, но все-таки...

    зы Прошу, если это возможно, пояснить реализацию алгоритма выборки по условиям, ибо алгоритм копирования собранного табеля на лист отчета, с переименованием его в определенном формате, у меня уже есть.
    Как я сам себе придумал надо:
    - опросить последовательно ячейки с именами в Табеле
    - на основании полученного имени, - просмотреть листы с названиями отвечающими условиям выборки и найти там необходимый для копирования диапазон ячеек с данными,
    - скопировать этот диапазон (а лучше создать связь с данными этого диапазона) в соотвествующий этому имени диапазон ячеек в Табеле,
    - пройти по всем именам в шаблоне табеля и в конце предложить сохранить табель на новый лист(или, может лучше, лист табеля создавать из шаблона сначала, и в процессе работы макроса заполнить его выбранными данными из графиков).

    извиняюсьзаоченьмногобукв!!!

    зы зы Если, вдруг, кому-то станет интересно покопаться в этом... Ну и на всякий случай ...
    приложил файлик примера,
    но не разобрался как это можно тут сделать иначе чем https://dropmefiles.com/zMKcv.

    1. Антон, можете привести текст и номер ошибки? По сути варианта 2:
      1. Какой-то сбой. Иногда помогает добавление явной ссылки на приложение:
      Application.Workbooks.Open(Filename:=avFiles(li))
      2. Файлы расположены в папке, к которой не проставлено доверие и файлы открываются в защищенном режиме. Тогда тоже будет возникать ошибка, т.к. книга по сути недоступна для получения из неё данных.

  3. Добрый день.
    Дмитрий, если в собираемых книгах последняя ячейка объединенная, то макрос берёт не все столбцы. То есть, если в таблице, которая находится в диапазоне A1:G40, последняя ячейка - D40:G40 (объединенная), то макрос берёт только столбцы с A по D, не взяв столбцы с E, F и G. Потому что, в этом примере, ActiveSheet.Cells(1, 1).SpecialCells(xlLastCell).Column возвращает 4 (то есть столбец D), хотя есть данные и в столбцах E, F и G. Причина - последняя ячейка этого листа - объединенная (D40:G40).

    Перед строкой:
    lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row
    я написал:
    .Cells(1, 1).SpecialCells(xlLastCell).MergeCells=False

    Вроде работает.

    1. Очень странно, что SpecialCells(xlLastCell).Column возвращает 4, а не 7, как должно бы по спецификации быть. Пример бы такого файла глянуть. Да и ActiveSheet меня в этой записи смущает и Cells(1, 1). У меня в коде Cells(1, 1) для Column не применяется, не говоря уже про ActiveSheet. У меня все обращения идут к конкретным листам, а не к активному.
      А MergeCells=False - плохая практика, т.к. Вы снимаете объединение с ячейки исходных данных, которое возможно, нужно.

  4. Дмитрий, добрый день! Пытаюсь изучить ваш супер макрос) Подскажите следующие моменты пожалуйста:
    1. If VarType(avFiles) = vbBoolean Then Exit Sub - здесь не понимаю в каком случае avFiles может быть Boolean, ведь мы выбираем файлы в переменную avFiles, а это же String?
    2. If bPolyBooks Then - а здесь не пойму как работает синтаксис - если bPolyBooks - что? Т.е обычно же надо писать ЕСЛИ переменная = тому-то ТО ...
    Заранее спасибо за ответы!

    1. Annie91
      1. "в каком случае avFiles может быть Boolean" - если мы нажали кнопку Отмена вместо выбора файлов. Вот здесь описано чуть более подробно: Диалоговое окно выбора файлов/папки
      2. "если bPolyBooks - что?". По умолчанию, если у нас одно условие, то bPolyBooks будет сравниваться с True. Это если кратко, хотя история там чуть длиннее :)

  5. Здравствуйте, Дмитрий. Спасибо Вам за очень ценный скрипт. Всё вроде класс, но есть проблема: в создаваемом макросом массиве данных появляются неверные значения. У меня 8 исходных файлов: по одному файлу на каждый месяц 2020го года. В каждом количество листов соответствует количеству дней в соответствующем месяце. В создаваемом массиве в строках соответствующих 30му листу источника информации вместо нужных данных появляются другие значения. Я не могу их найти в исходнике. Зато в строках, которые должны соответствовать 31му листу значения соответствуют 30му листу.

  6. Дмитрий, спасибо Вам большое за макрос!

    Скажите, пожалуйста, при выборе нескольких книг (файлов *xls) выдает следующее окно:

    В буфере обмена находится большой объем данных. Сохранить эти данные для последующей вставки в другую программу? * Чтобы сохранить данные нажмите кнопку "ДА"

    Можно ли обойти эту процедуру ?
    Сбор данных начинаю всегда с ячейки A1.

    Заранее Спасибо!

  7. Добрый! При попытке простой сборки с двух листов ошибка на последнем шаге при отказе от сбора из других книг Object variable or With block variable not set
    cсылается на

    rCopy.Copy

  8. Дмитрий! Огромное спасибо за код! Даже то, что я его нашел уже облегчает работу на 50%. Разрешите вопрос: позволяет ли данный макрос при анализе абсолютно одинаковых таблиц на всех листах просуммировать данные ячеек? Или Ваш макрос чисто для объединения на 1 листе всех данных с других листов и книг? В моем случае у меня есть торговые объекты, по каждому объекту расход ТМЦ, например, кофе. Вот в сводной таблице хотелось бы объединить в одну ячейку весь расход по объектам. Решаемо?

    1. Евгений, решаемо. Но не этим кодом. Можно собрать данные, а потом на основе итоговой таблицы сделать сводную. Либо использовать Power Query: Собрать и просуммировать данные из разных файлов при помощи PowerQuery
      Или скачать мою надстройку(там сбор данных умеет агрегировать(сумма, кол-во и т.п.)): Сбор данных с нескольких листов/книг. Но она только месяц бесплатная, а потом увы...

      1. Пробовал Power Query. Но он тоже почему данные двух совершенно одинаковых таблиц сваливает друг за другом сверху вниз. Не пойму что не так делаю. Есть размышления?

        1. Евгений, на какой ответ рассчитываете, если у меня в видео все получается, а у Вас нет?
          Очевидно, где-то что-то забываете(группировать, например). А может еще что не так делаете. Откуда мне что-то знать, если Вы не дали никакой информации по своим действиям? :) Обратитесь в форум - PowerQuery, PowerPivot, PowerBI и запросы - создайте там тему, опишите свои действия и проблему, приложите файл запроса при необходимости.

          1. Здравствуйте. Попытался на форуме оставить сообщение. Зарегистрировался, но активация не происходит. А при попытке войти выходит сообщение "Извините, данная учетная запись не одобрена Администратором. Если Вам необходимо повторно отправить письмо с кодом активации, пожалуйста, нажмите здесь." Жму "здесь" и мне снова отправляет письмо, но на электронку ничего не приходит! В СПАМЕ пусто!!! второй день уже проверяю. Помогите, пожалуйста.

Добавить комментарий

Этот сайт использует Akismet для борьбы со спамом. Узнайте, как обрабатываются ваши данные комментариев.