Хитрости »
Основные понятия (22)
Сводные таблицы и анализ данных (6)
Графики и диаграммы (4)
Работа с VB проектом (10)
Power BI и Power Query (6)
Условное форматирование (5)
Списки и диапазоны (5)
Макросы(VBA процедуры) (60)
Разное (36)

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

Очень часто бывает необходимо собрать данные с нескольких листов одной книги или даже с листов нескольких книг. Например, каждую неделю мы получаем некие отчеты от отделов, которые необходимо собрать в одну общую таблицу для построения сводной таблицы. Или это могут быть некие книги прайсов по товарам от разных поставщиком, который опять же надо сначала объединить, а потом уже анализировать. Вручную делать это довольно муторно. И то, муторно это только для первых 20-ти листов/файлов, потом становится просто тошно. Поэтому решил поделиться решением, которое поможет собрать данные со всех листов книги, со всех листов всех указанных книг или только с указанных листов:

Приведенный выше код необходимо вставить в стандартный модуль(Что такое модуль? Какие бывают модули?). Выполнить его можно будет из этой книги нажатием клавиш Alt+F8. В появившемся окне выбрать Consolidated_Range_of_Books_and_Sheets и нажать Выполнить. Так же можно создать на листе кнопку и назначить ей данный макрос. Так же, если впервые работаете с макросами настоятельно рекомендую прочитать статью: Что такое макрос и где его искать?, а так же Почему не работает макрос?

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

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

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

Если после сбора данных обнаружили, что после каждого файла/листа много пустых строк, то следует найти в коде строку:
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 строк.

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

  Tips_Macro_Consolidated.xls (50,0 KiB, 23 008 скачиваний)

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


Статья помогла? Не держи в себе, поделись ссылкой с друзьями!

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

Access Multex Outlook Power BI Power Query и Power BI VBA работа в редакторе VBA управление кодами Бесплатные надстройки Дата и время Диаграммы и графики Записки Защита Защита данных Интернет Картинки и объекты Листы и книги Макросы и VBA Настройка Печать Поиск данных Поиск решения Почта Программы Работа с приложениями Работа с файлами Разработка приложений Сводные таблицы Списки Тренинги и вебинары Финансовые Форматирование Формулы и функции Функции Excel Функции VBA Ячейки и диапазоны акции MulTEx анализ данных вебинар ссылки статьи тренинг
Обсуждение: 291 комментарий
  1. Добрый день, скажите пожалуйста, данные у меня собраны так - http://joxi.ru/BA01zBBtBOg7ar
    Возможно ли добавить название столбцов, и фильтр

    Рейтинг: 0
  2. Алексей:

    Здравствуйте, Дмитрий!
    Решил воспользоваться Вашим макросом для копирования даных из 475 книг на один лист, но столкнулся с ошибкой VB Run-time eror '1004' (скрин ошибки https://1drv.ms/i/s!AhFACJaqXOEEgoxd8KR-BkJ-pHRAFQ), которая появляется после вставки из 8-ми первых кних. Книгу для вставки сохранял и в .xlsx и .xlsm - не помогло. Исходные файлы в формате .xls, по одному листу в каждой книге с идентичной структурой и размером данных A1:T101. т.е. конечный результат должен иметь 47500 строк данных, а работа скрипта заканчивается на 800...
    Помогите разобратся, пожалуйста!

    Рейтинг: 0
    • Алексей, а Вы не заметили, что текст ошибки пишет? Ровно то, что книгу не получается открыть. Т.е. метод Open просто не срабатывает. Посмотрите на какой книге останавливается код и изучите книгу. Возможно, она повреждена и не может быть открыта в режиме чтения/записи.

      Рейтинг: 0
  3. Дмитрий:

    Здравствуйте, подскажите пожалуйста, а как собрать данные с защищенных листов, пароль к которым я не знаю

    Рейтинг: 0
  4. Леонид:

    Спасибо за полезную статью! Очень пригодилось!

    Рейтинг: 0
    • Роман:

      Возможно кому пригодится, изменил код. Суть в том, что есть накладные с утвержденной формой. Накладные с разных объектов, которые нужно собрать в одну книгу. Причем, каждое направление(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 ExplicitSub 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 IfNEXT_:        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 = 1End Sub
      Вопросы на засыпку: все таки не происходит замены старых данных на новые при повторе макроса(сначала был потом пропал-мистика); как сделать запрос "Выберите направление 0,1,2,3" и чтобы введенное значение изменяло в программе имя листа на который будут скопированы данные.

      Рейтинг: 0
      • Роман, почитайте комментарии. Чтобы сбор данных происходил с заменой надо как минимум лист для сбора очищать от прежних данных. У Вас этого нет. Сделайте что-то вроде:

        вставить это надо вместо этого:

        Рейтинг: 0
        • Роман:

          Рабочий вариант:

          а на счет кнопки есть мысли? В каком направлении хотя бы смотреть...

          Рейтинг: 0
  5. Мария Дорофеева:

    Дмитрий, огромное Вам спасибо за макрос и за все ваши статьи и материалы! Очень полезно в работе. С помощью данного макроса сократила время выполнения своей задачи с 8 часов до получаса.

    Рейтинг: 0
  6. Юлия:

    Дмитрий, доброго времени суток!
    Подскажите, пожалуйста, все комментарии прочтены и учтены :)

    Беру Ваш код, немного его исправила по Вашим комментариям.
    Но только у меня проблема, видимо что то делаю не так(
    У меня есть три файла, нужно их свести, формат таблицы одинаковый, но только файлы разные, у кого то "простыня", а есть и совсем не много данных. Проблема: при первом варианте у меня все внизу собирается, но опять же с пустыми стоками между данными файлов, при втором варианте своди ровненько и красиво, без пустых строк, но почему то он переносит только последний файл (т.е. 1 из 3)Заранее благодарю за помощь!

    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
        
        'Указываем на какой лист в текущей книги собирать данные
        Set wsDataSheet = Worksheets("CPP").Range("A5").SpecialCells(xlCellTypeLastCell)
        lLastrow = wsDataSheet.Row
        iLastColumn = wsDataSheet.Column
        ThisWorkbook.Sheets("CPP").Range("A5:BP777777").Cells.ClearContents
        Set wsDataSheet = ThisWorkbook.Sheets("CPP").Range("A5")
        
        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
        'Указываем имя листа
        'Допустимо указывать в имени листа символы подставки ? и *.
        'Если указать только * то данные будут собираться со всех листов
        sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр")
        'Если имя листа не указано - данные будут собраны со вех листов
        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 = ActiveSheet
        'если нужно сделать сбор данных на новый лист книги с кодом
        '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(.Rows.Count, 7).End(xlUp).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.End(xlUp).Row + 4
                        'вставляем имя книги, с которой собраны данные
                        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
    Рейтинг: 0
    • уверены, что искать последнюю ячейку необходимо именно в 7-м столбце(G)?
      Плюс в этой строке ошибка:

      где Вы последнюю ячейку вычисляете? В каком столбце? По факту в данном случае эта строка всегда 5 будет возвращать...

      Рейтинг: 0
      • Юлия:

        Дмитрий, добрый день!
        Спасибо за ответ!
        Все верно, мне нужно смотреть по 7 столбцу, так как в 6 столбце есть формула, которая соединяет несколько ячеек и между значениями знак знак "-", соответственно даже когда формула ничего не соединяет у меня простыня из знаков " _-_"

        lLastRowMyBook = wsDataSheet.Cells.End(xlUp).Row + 4
        данное условие, как я понимаю, как раз начинает выводить информацию в 5 строку, так как "шапка" таблицы всегда одинаковая.Извините, не поняла, в чем ошибка?

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

        Рейтинг: 0
        • Юлия, ну хоть логику включите элементарную :)
          Сравните то, как Вы ищете последнюю строку в книгах и как в книге для сбора.
          Т.е. по сути у Вас данные каждой книги сейчас вставляются начиная с 5-ой строки. А должны в зависимости от данных вставляться - с просмотром заполненных данные в 7-м столбце.
          Что-то вроде:
          lLastRowMyBook = wsDataSheet.Cells(wsDataSheet.Rows.count,7).End(xlUp).Row
          if lLastRowMyBook = 1 then lLastRowMyBook = 5 'если данных на листе еще нет - с 5-ой строки

          Рейтинг: 0
          • Юлия:

            Благодарю! спасибо вам огромное!!! все получилось!!! хорошего Вам дня :)

            Рейтинг: 0
Поделитесь своим мнением

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


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

Тренинги

Заказать
Наши партнеры
Перейти
Перейти
Счетчики
Анализ сайта

Яндекс.Метрика
© 2017 Excel для всех  Войти
Авторизация
*
*
Регистрация
*
*
*
Пароль не введен
*
captcha
Перейти на страницу