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 832 скачиваний)

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


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

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

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

  2. Алексей:

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

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

  3. Дмитрий:

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

  4. Леонид:

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

    • Роман:

      Возможно кому пригодится, изменил код. Суть в том, что есть накладные с утвержденной формой. Накладные с разных объектов, которые нужно собрать в одну книгу. Причем, каждое направление(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" и чтобы введенное значение изменяло в программе имя листа на который будут скопированы данные.

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

        'Указываем на какой лист в текущей книги собирать данные
        On Error Resume Next
        Application.Displayalerts = false
        ThisWorkbook.Sheets("0").Delete
        Set wsDataSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsDataSheet.Name = "0"
        Application.Displayalerts = true

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

        'Указываем на какой лист в текущей книги собирать данные
        Set wsDataSheet = ThisWorkbook.Sheets("0")
        • Роман:

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

          'Указываем на какой лист в текущей книги собирать данные
              Set wsDataSheet = Worksheets("0").Range("A1").SpecialCells(xlCellTypeLastCell)
              lLastRow = wsDataSheet.Row
              iLastColumn = wsDataSheet.Column
              ThisWorkbook.Sheets("0").Cells.ClearContents
              Set wsDataSheet = ThisWorkbook.Sheets("0")

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

  5. Мария Дорофеева:

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

  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
    
    
    		
    				
    • 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 строку, так как "шапка" таблицы всегда одинаковая.Извините, не поняла, в чем ошибка?

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

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

          • Юлия:

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

  7. Федор:

    Здравствуйте, Дмитрий! Спасибо за Ваш труд. Макрос работает прекрасно, нареканий нет. У меня есть два вопроса(в комментариях искал ответ на свои вопросы, но не нашел) :
    1) макрос вставляет помимо информации еще и название файла excel, к примеру : "20.10_Компания N.xls" . Можно сделать так , чтобы он не вставлял названия файлов?
    2)Данный вопрос очень наглый с моей стороны, буду очень признателен, если на него тоже ответите : у меня макрос копирует таблицу из 4 строк в которых данные и вставляет их также в 4 строки,как и копировал. Можно ли сделать так, чтобы макрос вставлял копированные данные сразу в одну ячейку и так далее, то есть скопировал из первой книги данные и вставил в ячейку,потом данные из второй книги в соседнюю ячейку и т.д. ?

    • Федор, по первому:
      достаточно перед строкой с комментарием:

      'цикл по книгам

      вставить следующую строку:
      lCol = 0
      По второму: слишком много дорабатывать надо, чтобы это реализовать в данном коде.

  8. Никита:

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

  9. Никита:

    Спасибо, попробую. А пробной версии достаточно будет или нужна полная?

  10. Алексей:

    День добрый!
    Прошу помочь с написанием макроса для следующих задач.

    Написать марос, который собирает листы "акция" из всех файлов текущей папки в данный файл.
    Каждый собранный лист должен носить название книги, из которой он взят.
    С помощью макроса заполнить таблицу на листе "Сводная", в которую должны войти данные из всех собранных листов: "Москва", " Самара", Краснодар" и "Ростов"

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

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


Для оформления сообщений Вы можете использовать следующие тэги:
<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 для всех   Войти