Lost your password?


Хитрости »
Основные понятия (27)
Сводные таблицы и анализ данных (10)
Графики и диаграммы (5)
Работа с VB проектом (12)
Power BI и Power Query (23)
Условное форматирование (5)
Списки и диапазоны (5)
Макросы(VBA процедуры) (68)
Разное (43)
Баги и глюки Excel (5)

Как собрать данные с нескольких листов или книг?

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

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


Статья помогла? Поделись ссылкой с друзьями!
  Плейлист   Видеоуроки

Поиск по меткам

Access apple watch Multex Power Query и Power BI VBA управление кодами Бесплатные надстройки Дата и время Записки ИП Надстройки Печать Политика Конфиденциальности Почта Программы Работа с приложениями Разработка приложений Росстат Тренинги и вебинары Финансовые Форматирование Функции Excel акции MulTEx ссылки статистика
Обсуждение: 411 комментариев
  1. Константин:

    Добрый день! Скачал файл, запустил макрос, но возникла ошибка макроса на функции oAwb = wbAct.Name

    • Константин, спасибо. Недавно чуть изменил код и пропустил пару строк. Файл перезалил, код в статье поправил. Так что можете скачать заново и попробовать.
      Ошибка скорее всего возникала при попытке сбора данных с текущей книги.

  2. Гавриил:

    Спасибо за информацию, размещенную на сайте. Макрос по сбору данных очень выручил.

  3. Олег Л:

    Очень кропотливо проделанная работа!
    Добавлю для тех кто хочет не изменять название обработанных листов
    sSheetName = "Лист1"
    Спасибо.

  4. Ri:

    Макрос собирает из разных книг либо все либо заданные листы в один лист текущей книги. Как сделать так чтобы макрос собирал из разных книг все листы с именем "1" на лист с именем "1" текущей книги, листы с именем "2" на лист "2" текущей книги.

  5. Олег Л:

    Дмитрий, нашёл проблему макроса:
    макрос отлично работает когда задается не одна ячейка а несколько, но если указать только одну ячейку, то вылетает ошибка на строке сразу при первом проходе цикла:
    lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row

    сам вожусь чтобы перебирать по одной ячейке путём перебора определённого массива.

  6. Олег Л:

    Ругается на защищенность бланка листа.
    Когда задаешь диапазон ячеек - всё нормально, читает и защищенные листы. пока копаюсь.

    • Дело не в количестве указанных ячеек, а в том, что SpecialCells не работает на защищенных листах. Поэтому и получаете ошибку. Либо защиту снимайте, либо используйте UsedRannge:

      lLastR = .UsedRange.Row + .UsedRange.Rows.count-1
      lLastR = .UsedRange.Column + .UsedRange.Columns.count-1
  7. Александр:

    Что нужно поправить в коде что бы на каждый файл был свой столбец, а имена файлов лишь в одной строке в начале столбца? Из 10 тысяч файлов один столбу в 2 тысячи строк в одном столбце итоги не сведешь.

  8. Сергей:

    Подскажите, я немного поменял код и у меня теперь вставляются данные не в первую строчку, а в 74 693 строчку, что нужно сделать, чтобы данные вставлялись в первую строку? Я только лишь поменял порядок, убрал некоторые диалоговые окна и вставлял данные не на нровый лист, а на лист "Все данные".

    • Сергей, Вы что-то поменяли и мне теперь предлагаете угадать что такого Вы там еще сделали, из-за чего теперь проблема? Даже код не выложили. Предположение только одно: Вы убрали создание нового листа и просто добавили очистку одного листа и на него же сбор данных осуществляете. В этом случае последнюю ячейку надо иначе определять. Почитайте комментарии - уже разбиралась такая ситуация.

      • Сергей:

        Извиняюсь, поторопился

        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
         
            On Error Resume Next
            'для указания диапазона без диалогового окна:
            Set iBeginRange = Range("A1:J200") 'диапазон указывается нужный
            'Если диапазон не выбран - завершаем процедуру
            If iBeginRange Is Nothing Then Exit Sub
            'Если имя листа не указано - данные будут собраны со вех листов
            If sSheetName = "" Then sSheetName = "*"
            On Error GoTo 0
            'Запрос - вставлять на результирующий лист все данные
            'или только значения ячеек (без формул и форматов)
            bPasteValues = (MsgBox("Вставлять только значения?", vbQuestion + vbYesNo, "Excel-VBA") = vbYes)
            'Запрос сбора данных с книг(если Нет - то сбор идет с активной книги)
            If MsgBox("Собрать данные с нескольких книг?", vbInformation + vbYesNo, "Excel-VBA") = 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
            'отключаем обновление экрана, автопересчет формул и отслеживание событий
            'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды
            With Application
                lCalc = .Calculation
                .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
            End With
            'если нужно сделать сбор данных на новый лист книги с кодом
            Set wsDataSheet = Sheets("Все данные")
            'цикл по книгам
            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
                            'вставляем имя книги, с которой собраны данные
                            If lCol Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(Range(sCopyAddress).Rows.Count).Value = oAwb
                            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 wbAct.Close False
            Next li
            With Application
                .ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc
            End With
        End Sub
        • Сергей, я уже написал выше предполагаемую причину - можно почитать комментарии, ответ уже был на подобную ситуацию. Вы собираете данные на фиксированный лист и диапазоны фиксированные, что меняет подход по определению последней ячейки листа. Старайтесь хоть по подсказкам ответ искать самостоятельно.
          Строку
          lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row
          замените на нечто вроде
          lLastrow = .Cells(.Rows.Count, 1).End(xlup).Row
          Тоже самое и со строкой:
          lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
          Почитайте на сайте статью про определение последней ячейки через VBA - тогда поймете что происходит. А для столбца последнего можно вообще фиксированное значение задать, раз диапазон сбора фиксированный.

  9. Елена:

    Дмитрий, добрый день!
    Отличный макрос. Спасибо!
    Все работает. У меня один вопрос.. у меня при объединении книг (по умолчанию проставила что всегда данные необходимо собирать начиная с ячейки $A$4) все работает корректно.. но собранные данные всегда начинают вставляться на новый лист начиная со второй строки.. как-то можно зафиксировать чтобы собранные данные всегда собирались начиная так же с фикисированной ячейки $A$4 ? Перечитала все комментарии но не смогла понять как мне изменить код(

    • Елена, добавьте перед этой стройкой:

      If bPasteValues Then 'если вставляем только значения

      такую:

      If lLastRowMyBook < 4 Then lLastRowMyBook = 4
  10. Кирилл:

    Огромное спасибо за макрос. Подскажите пожалуйста, как его доработать, а именно: брать файлы не только из выбранной папки но и из ее под папок?
    Нашел функцию FilenamesCollection заменил часть кода
    с
    avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
    на

    avFiles = FilenamesCollection("C:\Users\Кирилл\Desktop\ЭА\-\", ".xls*", 4)

    но не выходит.

Поделитесь своим мнением

Комментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум


Для оформления сообщений Вы можете использовать следующие тэги:
<a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <s> <strike> <strong>

Тренинги

Заказать
Юридическая информация

Использование материалов сайта

Политика Конфиденциальности

ИП Щербаков Дмитрий Валентинович
ОГРНИП: 318502700083307
ИНН: 504013350772

Наши партнеры

Перейти

Счетчики

Рейтинг@Mail.ru Яндекс.Метрика
© 2024 Excel для всех   Войти