Сбор данных из файлов Excel в заданной папке

Обработка данных из файлов Excel - отображение информации на индикаторе состояния

Этот макрос предназначен для сбора (загрузки) информации из файлов Excel, расположенных в одной папке.

Для работы этого макроса, помимо него самого, вам понадобится добавить в свой файл:

функцию FilenamesCollection для получения списка файлов в папке
функцию GetFolder для вывода диалогового окна выбора папки с запоминанием выбранной папки
прогресс-бар для отображения процесса обработки файлов (модуль класса и форму)

Если при тестировании макроса у вас возникает ошибка, что не найдена та или иная функция,
— проверьте, все ли необходимые компоненты (которые перечислены выше) вы добавили в свой файл.

Этот макрос я публикую прежде всего для себя (поскольку использую этот код чуть ли ни в каждой третьей своей программе),
поэтому я не буду помогать вам в настройке этого макроса, если у вас он вдруг не заработает.

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

После того, как очередной файл обработан, он перемещается во вторую папку («архив»).

Код макроса:

Sub ИмпортДанныхИзЗаявок()
    On Error Resume Next: Err.Clear
    ' запрашиваем пути к папкам с файлами
    InvoiceFolder$ = GetFolder(1, , "Выберите папку с файлами заявок (из Outlook)")
    If InvoiceFolder$ = "" Then MsgBox "Не задана папка с заявками", vbCritical, "Обработка заявок невозможна": Exit Sub
 
    ArchieveFolder$ = GetFolder(2, , "Выберите папку, куда будут помещаться обработанные файлы заявок")
    If ArchieveFolder$ = "" Then MsgBox "Не задана папка для архива заявок", vbCritical, "Обработка заявок невозможна": Exit Sub
 
    Dim coll As Collection
    ' загружаем список файлов по маске имени файла
    Set coll = FilenamesCollection(InvoiceFolder$, "Заявка №*от*.xls*", 1)
 
    If coll.Count = 0 Then
        MsgBox "Не найдено ни одной заявки для обработки в папке" & vbNewLine & InvoiceFolder$, _
               vbExclamation, "Нет необработанных заявок"
        Exit Sub
    End If
 
    Dim pi As New ProgressIndicator: pi.Show "Обработка заявок", , 2
    pi.StartNewAction , , , , , coll.Count    ' отображаем прогресс-бар

    Dim WB As Workbook, sh As Worksheet, ra As Range
    Application.ScreenUpdating = False  ' отключаем обновление экрана (чтобы процесс открытия файлов не был виден)

    ' перебираем все найденные в папке файлы
    For Each Filename In coll
 
        ' обновляем информацию на прогресс-баре
        pi.SubAction "Обрабатывается заявка $index из $count", "Файл заявки: " & Dir(Filename), "$time"
        pi.Log "Файл: " & Dir(Filename)
 
        ' открываем очередной файл в режиме «только чтение»
        Set WB = Nothing: Set WB = Workbooks.Open(Filename, False, True)
 
        If WB Is Nothing Then    ' не удалось открыть файл
            pi.Log vbTab & "ОШИБКА при загрузке файла. Файл не обработан."
 
        Else    ' файл успешно открыт
            Set sh = WB.Worksheets(1)    ' будем брать данные с первого листа
            ' берем диапазон ячеек с ячейки B1 до последней заполненной в столбце B
            Set ra = sh.Range(sh.Range("b1"), sh.Range("b" & sh.Rows.Count).End(xlUp))
 
            ' ==== переносим данные в наш файл (shb - кодовое имя листа, куда помещаем данные)
            shb.Range("a" & shb.Rows.Count).End(xlUp).Offset(1).Resize(, ra.Rows.Count).Value = _
            Application.WorksheetFunction.Transpose(ra.Value)
            ' ==== конец обработки данных из очередного файла

            WB.Close False: DoEvents    ' закрываем обработанный файл без сохранения изменений
            pi.Log vbTab & "Файл успешно обработан."
 
            ' перемещаем обработанный файл из папки InvoiceFolder$ в папку ArchieveFolder$
            Name Filename As ArchieveFolder$ & Dir(Filename, vbNormal)
 
        End If
    Next
 
    ' закрываем прогресс-бар, включаем обновление экрана
    pi.Hide: DoEvents: Application.ScreenUpdating = True
    MsgBox "Обработка заявок завершена", vbInformation
End Sub

Во вложении - файл со всеми необходимыми макросами для сбора данных из других файлов Excel

Вложения:

MergeWorkbooks.xls

117 КБ

185517 просмотров

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Игорь (администратор сайта), 8 Дек 2016 - 19:47.#1

Нет там никакого ограничения по запускам (код открыт, можете сами убедиться)
Расширить столбцы ничто вам не мешает, никаких ограничений и защит в прикреплённом файле нет
Где что подправить - не подскажу (техподдержки по бесплатным макросам нет)
Если сами не разберетесь, - могу сделать под заказ (минимальная стоимость заказа - 1500 руб)

Александр, 8 Дек 2016 - 18:51.#2

Добрый День!. Я смотрю у вас макрос расчитан на 3000 запусков а потом всё? И второй момент, расшить столбцы более J это уже платно? или где то подправить я могу, я смотрю вы все диапазонами обзывали в макросах собирающихся.

Дмитрий, 21 Окт 2016 - 03:23.#3

Проблемма решилась самостоятельно, нужно было всего лишь переоткрыть файл для применения изменений формата.

Дмитрий, 21 Окт 2016 - 00:51.#4

Доброго времени суток, не могли бы вы подсказать, почему при коллекционировании более, чем 64000 строк макрос перестает вставлять данные?
книга была сохранена в формат .xlsb
ошибка следующая:
для
shd.Range("a" & shd.Rows.Count).End(xlUp).Offset(1).Resize(ra.Rows.Count, ra.Columns.Count).Value
выдает сообщение: "Application-defined or object-defined error"

Игорь (администратор сайта), 25 Июл 2016 - 22:51.#5

Оформляйте заказ на сайте, - сделаем.

Гость, 25 Июл 2016 - 13:00.#6

Уважаемы гуру VBA помогите новичку не провалить задание.
Дело в том, что с разных отделов ( около 40) мне шлют заполненную таблицу Excel, универсальную для всех.
Разница лишь в цифрах, которые туда заносит каждый отдел исходя из своих показателей. Мне нужно создать сводную, одну таблицу, которая бы суммировала значения всех отделов. Неизменными остаются -шапка таблицы и столбец с названием показателей. Помогите создать макрос.

Alexander Solodilov, 22 Июл 2016 - 18:43.#7

Спасибо, очень помог макрос после небольшой доработки!

Максим, 20 Июл 2016 - 23:50.#8

Доброго времени суток!
Скачал Ваш файл с макросами. Как теперь добавить необходимую мне информацию из книг, откуда идет сбор информации, в эту книгу?
Спасибо за ответ.

Игорь (администратор сайта), 22 Июн 2016 - 18:24.#9

Иван, оформляйте заказ, прикрепляйте к нему примеры файлов, и подробно описывайте, что и как должно работать.

Иван, 22 Июн 2016 - 17:46.#10

Добрый день. Вот такая есть у меня задачка, в Excel я чайник. Помогите решить ее. Суть в следующем. Есть некое количество файлов Excel в папке, каждый день разное (от 100 до нескольких тысяч), нужен вывод названия каждого файла в общую таблица, строка названия файла в графе с подсчетом строк в каждом фале, исключая шапку, общие число файлов.И желательно интеграция в word. Как прикрепить таблицы для примера?

Гость, 3 Июн 2016 - 16:47.#11

Добрый день!

нарисовал в коде вот так:

'If (sh.Range("c45") = 1) Then
'shd.Range("f" & shd.Rows.Count).End(xlUp).Offset(1).Resize(1, 1).Value = Array(sh.Range("e45"))
'End If 'Направления использования - командировочные

'If (sh.Range("c47") = 1) Then
'shd.Range("f" & shd.Rows.Count).End(xlUp).Offset(1).Resize(1, 1).Value = Array(sh.Range("e47"))
'End If 'Направления использования - хозрасходы

'If (sh.Range("c49") = 1) Then
'shd.Range("f" & shd.Rows.Count).End(xlUp).Offset(1).Resize(1, 1).Value = Array(sh.Range("e49"))
'End If 'Направления использования - внесение средств

'If (sh.Range("c51") = 1) Then
'shd.Range("f" & shd.Rows.Count).End(xlUp).Offset(1).Resize(1, 1).Value = Array(sh.Range("e51"))
'End If 'Направления использования - Иное

Все отлично работает и в итоговую таблицу записывается значение из соответствующего столбца "e" если в столбце "с" только одно вхождение "1". В противном случае если "1" несколько то в таблицу добавляются дополнительные строки. Можно как то поправить, что бы при нескольких вхождениях "1" в столбце "c" в итоговую таблицу записывались данные соответствующей строки из столбца "e" в одну ячейку через разделитель.

Александра, 29 Май 2016 - 17:13.#12

Спасибо, сработало)

Игорь (администратор сайта), 29 Май 2016 - 17:05.#13

так попробуйте

With shd.Range("a" & shd.Rows.Count).End(xlUp).Offset(1, 1).Resize(ra.Rows.Count, ra.Columns.Count)
    .Value = ra.Value ' начиная со второго столбца, вставляем 10 столбцов данных
    .EntireRow.Columns(1).Value = WB.Name ' в первый столбец вставляем имя файла
End With

Александра, 29 Май 2016 - 16:47.#14

Пытаюсь добавть название файла. Макрос либо вставляет только название файла в 10-ю ячейку, либо ничего не вставляет
With shd.Range("a" & shd.Rows.Count).End(xlUp).Offset(1).Resize(ra.Rows.Count, ra.Columns.Count).Value = ra.Value
.EntireRow.Cells(ra.Rows.Count, 10) = WB.Name
End With

Игорь (администратор сайта), 28 Май 2016 - 19:55.#15

Да, можно. Поищите пример кода в комментах (вроде было)
Либо можем сделать под заказ (если готовы оплатить)

Александра, 28 Май 2016 - 18:25.#16

Добрый день!

Можно ли добавить для каждой строчки в последний столбец название файла, из которого была вставка? спасибо

Rick_77, 27 Май 2016 - 12:55.#17

Благо Дарю за ответ! Подсказка была уместной, получилось! Удачи!

Игорь (администратор сайта), 27 Май 2016 - 12:23.#18

Да нет там никаких ограничений...

в коде задано количество столбцов, считываемых их обрабатываемого файла

' берем диапазон ячеек с ячейки A2 до последней заполненной в столбце A
Set ra = sh.Range(sh.Range("a2"), sh.Range("a" & sh.Rows.Count).End(xlUp)).Resize(, 10)

число 10 здесь - количество столбцов

Сколько столбцов считано - столько и выведется в сводный файл
В сводном файле столбцы после 10-го скрыты (ничто не мешает вам их отобразить)

Rick_77, 27 Май 2016 - 12:15.#19

Доброго дня Николай! Скажите, Вы решили проблему ограничения столбцов в макосе MergeWorkbooks.xls? если да, то поделитесь опытом! Всего доброго!

Mike, 12 Ноя 2015 - 00:31.#20

У меня макрос работает только с первыми 10 столбцами. Подскажите, пожалуйста, что делать, если в обрабатываемой таблице 20 столбцов? Как убрать ограничение?

Гость, 22 Окт 2015 - 14:31.#21

Для копирования ячеек с форматированием + гиперссылки меняем строку в макросе скачанного файла
прям всё переделывать не нужно всего 1-ну строку

' ==== переносим данные в наш файл (shb - кодовое имя листа, куда помещаем данные)
sh.Range(sh.Range("a2"), sh.Range("a" & sh.Rows.Count).End(xlUp)).Resize(, 10).Copy Destination:=shd.Range("a" & shd.Rows.Count).End(xlUp).Offset(1).Resize(ra.Rows.Count, ra.Columns.Count)
' ==== конец обработки данных из очередного файла
и очистка формата на
On Error Resume Next: shd.UsedRange.Offset(2).Clear

Люди пользуйтесь

А ВЫ УШЛЫЕ ВЫ БАБУЛЬКИ !!!!

Игорь (администратор сайта), 20 Окт 2015 - 18:48.#22

Есть такая функция у меня на сайте
http://excelvba.ru/code/JoinedArray

Гость, 20 Окт 2015 - 18:43.#23

привет , такая проблемка , нужно соеденить одинаковые строки с одинаковыми значаниями в макросе, не подскажите как это сделать ?

Игорь (администратор сайта), 15 Окт 2015 - 15:05.#24

Для этого надо переделывать макрос, и надо видеть файлы ваши, чтобы переделать.
Могу сделать под заказ.

Гость, 15 Окт 2015 - 14:49.#25

Как допилить, что бы скрипт собирал ячейки копировались с гиперссылками а не только заначение

Игорь (администратор сайта), 9 Окт 2015 - 19:54.#26

Николай, чтобы не было ограничения в 65 тыс строк, просто пересохраните файл с макросом в формате «двоичная книга Excel» (расширение XLSB) или «Excel 2007 с поддержкой макросов» (расширение XLSM)
И будет у вас в файле миллион строк.

Юрий, чтобы имя файла выводилось, надо заменить код

' ==== переносим данные в наш файл (shb - кодовое имя листа, куда помещаем данные)
            shb.Range("a" & shb.Rows.Count).End(xlUp).Offset(1).Resize(, ra.Rows.Count).Value = _
            Application.WorksheetFunction.Transpose(ra.Value)
            ' ==== конец обработки данных из очередного файла

на что-то типа такого

' ==== переносим данные в наш файл (shb - кодовое имя листа, куда помещаем данные)
With shb.Range("a" & shb.Rows.Count).End(xlUp).Offset(1).Resize(, ra.Rows.Count)
    .Value = Application.WorksheetFunction.Transpose(ra.Value)
    .EntireRow.Cells(6) = wb.Name        ' имя файла в 6 столбец
End With
' ==== конец обработки данных из очередного файла

Николай, 9 Окт 2015 - 12:10.#27

А как сделать, чтобы чтобы не было ограничений по строкам, а то максимум получается 65000 строк?

Юрий, 8 Окт 2015 - 13:27.#28

Подскажите, как сделать, что нужно добавить или изменить в данном макросе чтобы
в отдельном столбце, например в стобце F отображалось название файла с которого был перенос данных.
Спасибо за ответ.

Гость, 23 Сен 2015 - 18:46.#29

Спасибо за макрос, переделал по свои нужды. Автору Респект!

Alexander, 17 Сен 2015 - 23:18.#30

Спасибо за макрос
Мне нужно изменить строчку
Set ra = sh.Range(sh.Range("b1"), sh.Range("b" & sh.Rows.Count).End(xlUp))
Я хочу чтобы 10 строка только копировалась
Я изменил ее на
Set ra = sh.Range(sh.Range("a10"), sh.Range("x" & sh.Rows.Count).End(xlUp)).Resize(, 25)
то есть копираует с а10 по х10
Проблема в том что он тянет все строки с а1 по а10. а Мне только нужна 10 строка
Помогите пожалуйста

Игорь (администратор сайта), 30 Июн 2015 - 23:36.#31

Здравствуйте, Дмитрий.
Да, можно.

Дмитрий, 30 Июн 2015 - 23:20.#32

Здравствуйте! Подскажите пожалуйста а можно в файл Excel загрузить данные из другого Файла excel, с указание путь к загрузочному файлу

Максим, 19 Июн 2015 - 11:33.#33

Уважаемые специалисты,

Подскажите, пожалуйста, как изменить строку shd.Range("a" & shd.Rows.Count).End(xlUp).Offset(1).Resize(ra.Rows.Count, ra.Columns.Count).Value = ra.Value таким образом, чтобы результат записывался не в столбец, а в строку?

Спасибо.

Игорь (администратор сайта), 9 Июн 2015 - 17:47.#34

В коде (тем более, прогресс-бара), скорее всего, косяков нет
Возможно, с обрабатываемыми файлами что-то не так.
Я не занимаюсь техподдержкой бесплатных макросов, - потому, подсказать ничего не смогу.
Если нужно готовое решение, - можем сделать под заказ.

Владимир, 9 Июн 2015 - 17:29.#35

Есть косяк в отображении логов в прогресс-баре
https://www.youtube.com/watch?v=Za2E3HI0tOw

На четвертом или пятом файле глюк. Потом до конца нормально отображает.
Подскажите где копать?

Игорь (администратор сайта), 8 Июн 2015 - 22:51.#36

Эдуард, замените эти 2 строки кода на одну типа такой:

shd.Range("a" & shd.Rows.Count).End(xlUp).Offset(1).Resize(1, 5).Value = array(sh.Range("a1"),sh.Range("a2"),sh.Range("b33"),sh.Range("f4"),sh.Range("f6"))

Эдуард, 8 Июн 2015 - 20:54.#37

Здравствуйте.
Спасибо за отличный макрос, то что мне нужно, только надо поправить пару строк...
Set ra = sh.Range(sh.Range("n2330"), sh.Range("n" & sh.Rows.Count).End(xlUp)).Resize(, 1)

shd.Range("a" & shd.Rows.Count).End(xlUp).Offset(1).Resize(ra.Rows.Count, ra.Columns.Count).Value = ra.Value

Мне нужен не массив данных, а вставка 4-5 конкретных ячеек в одну строку, не подскажете как изменить эти строчки?
Спасибо

Игорь (администратор сайта), 22 Май 2015 - 04:57.#38

В статье не весь код написан.
Во вложении к статье, - файл со всеми необходимыми макросами.
Откройте этот файл, - и скопируйте оттуда весь код (+ модуль класса и форму прогресс-бара)

Nikita, 21 Май 2015 - 12:39.#39

Добрый день. Хотел посмотреть работу макроса и скопировал данный код себе в vba. При запуске макроса в отношении функции GetFolder сразу же вылетает ошибка : Compile error , Sun or Function not defined. Попробовал в библиотеке поискать эту функцию и также не нашел. Excel 2013 стоит. Что не так?

Игорь (администратор сайта), 17 Май 2015 - 15:08.#40

Здравствуйте, Рафаэль.
Да, конечно можно.
Оформляйте заказ на сайте, прикрепляйте примеры файлов, и подробно описывайте, что и как должно работать.

Рафаэль, 17 Май 2015 - 12:11.#41

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

Руслан, 1 Май 2015 - 17:08.#42

Сохраните файл в формате xlsm.
У вас скорее всего не помещаются по столбцам данные.
В xls формате их мало.
И надо как-то на стартовом листе кол-во столбцов увеличить, т.к. каким-то способом они там скрыты.
Или по инструкции ниже сделать импорт на конкретный лист. Тогда можно в книгу добавить лист и на него сослаться.

Игорь (администратор сайта), 3 Мар 2015 - 15:06.#43

Минимальная стоимость заказа у нас, — 1000 рублей
Да, Webmoney мы принимаем

Вячеслав, 3 Мар 2015 - 06:57.#44

Сколько будет стоить? и можно ли оплатить вебмани WMZ.

Игорь (администратор сайта), 2 Мар 2015 - 18:59.#45

Здравствуйте, Вячеслав.
Сделать-то несложно (несколько строк кода добавить), но я не занимаюсь бесплатной доработкой бесплатных макросов.
Можем сделать под заказ (недорого)

Вячеслав, 28 Фев 2015 - 20:06.#46

Добрый день,
Как сделать чтоб ещё добавлялось название файла и данные определённой ячейки (из листов хоронящихся в папке).
Если не сложно. Буду очень признателен.

Гость, 19 Ноя 2014 - 11:30.#47

Спасибо разобрался с границами ячеек. Камент не нужен

Гость, 19 Ноя 2014 - 09:38.#48

Здравствуйте.Подскажите пожалуйста, после добавления колонок в сводную таблицу, данные переносятся, все ок, НО у ячеек в добавленных столбцах нет границ. Все обшарил - не нашел ((

Сергей, 9 Ноя 2014 - 22:51.#49

Разобрался :) Теперь сижу построчно все разбираю как работает.Буду пробовать вставить имена файлов откуда берется все в первый столбец. Ну и еще что нибудь :) А вообще как пример что можно сделать очень хороший.

Игорь (администратор сайта), 9 Ноя 2014 - 16:08.#50

Сергей, если сами не разберетесь, можете оформить заказ на сайте (с примерами файлов), - тогда получите готовое решение.
Не видя файлов, тут сложно что-либо посоветовать

Отправить комментарий

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.

Сбор данных из файлов Excel в заданной папке

Комментарии

Настройки просмотра комментариев

Отправить комментарий

НАДСТРОЙКИ ДЛЯ EXCEL