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

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

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

 

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

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

 

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

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

 

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

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

 

Код макроса:

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.xls117 КБ3072 недели 4 дня назад

Комментарии

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

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

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

Николай, чтобы не было ограничения в 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
' ==== конец обработки данных из очередного файла

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

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

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

Спасибо за макрос
Мне нужно изменить строчку
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 строка
Помогите пожалуйста

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

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

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

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

Спасибо.

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

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

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

Эдуард, замените эти 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"))

Здравствуйте.
Спасибо за отличный макрос, то что мне нужно, только надо поправить пару строк...
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 конкретных ячеек в одну строку, не подскажете как изменить эти строчки?
Спасибо

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

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

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

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

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

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

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

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

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

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

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

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

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

Не получается транспонирование массива, даже если его одномерным сделать :(

shb.Range("a" & shb.Rows.Count).End(xlUp).Offset(1).Resize(, ra.Rows.Count).Value_
Application.WorksheetFunction.Transpose (ra.Value)

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

Set ra = sh.Range(sh.Range("D9:D12"), sh.Range("D" & sh.Rows.Count).End(xlUp)).Resize(5, 1)
shd.Range("b" & shd.Rows.Count).End(xlUp).Offset(1).Resize(ra.Rows.Count, ra.Columns.Count).Value = ra.Value

в этому случае выводит заданный диапазон Resize, в столбец b.Но как только добавляю

Application.WorksheetFunction.Transpose (ra.Value)

сразу же опять пустой результат

Тогда я что то не так делаю..У меня все равно выводит все в 1 столбец. Буду разбираться..А за пояснение спасибо огромное, новое для себя узнал

Сергей, так в коде есть и транспонирование, и данные в каждого нового файла вставляются в строку ниже:

 shb.Range("a" & shb.Rows.Count).End(xlUp).Offset(1).Resize(, ra.Rows.Count).Value = _
            Application.WorksheetFunction.Transpose(ra.Value)

shb.Range("a" & shb.Rows.Count).End(xlUp) - это поиск последней заполненной строки
.Offset(1) - отступ на одну строку вниз
Application.WorksheetFunction.Transpose - транспонирование загруженного из очередного файла диапазона

Хм.прикольная программа! а как интересно добавить транспонирование каждого диапазона и переход на новую строчку?

Серафим, для бесплатных макросов техподдержки нет
Любые доработки, - только под заказ (за денежку)

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

Здравствуйте, Алексей.
Если вас нет желания разбираться с кодом, - не проблема, можно сделать под заказ макрос, в точности подходящий под ваши нужды.
Оформляйте заказ на сайте, - сделаем.
А если хотите бесплатную помощь, - обращайтесь на форумы по Excel.

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

Структура книг одинаковая ... 2 листа, один из них Называется "Кондитерская", другой "Хлеб и Тесто". Первый столбик на листах - это просто наименования товаров, во втором это наименование точки, а под ним они подставляют то что им нужно, вбивая цифры напротив наименования продукта.

Точек 10 штук, т.е. просто из каждой книги с первого листа "Кондитерская" собрать все вторые столбики и поместить друг за другом на первом листе Общей книги на лист "Кондитерская" со всеми заказами... и со 2го листа "Хлеб и тесто" так же все заказы вставить уже на второй лист общей книги.

Желательно чтобы присутствовал общий итог каждой строчки всех листов.
На http://rghost.ru/57111615 хранится папка с примером.

огромное спасибо. вы мне очень помогли.

В макросе привязка не к имени листа, а к КОДОВОМУ ИМЕНИ ЛИСТА
оно меняется в редакторе VBA, в свойствах листа

ну или замените код

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

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

Перенесла все модули и формы в свой файл, поменяла в коде имя листа в который необходимо вставлять данные. Макрос ошибку не выдает, но и данные не вставляет. Имя прописано верно, попробовала поменять имя в вашем файле с макросами и поменяла имя в коде на аналогичное - все работает. А в моем файле нет(((

Упс, приношу свои извинения за глупый вопрос, ответ не требуется.

Доброе утро, Игорь!
подскажите, пжл, как в вашем прикрепленном файле увеличить кол-во столбцов?
у вас отображается всего 10, у мне нужно 44.

Денис, я же не телепат, чтобы, не видя ваших файлов, предложить готовый код.
Оформляйте заказ, прикрепляйте примеры файлов, - и получите макрос, в точности соответствующий вашим требованиям.

что то никак не могу осуществить перенос нужных столбцов, можете подтолкнуть меня в нужную сторону?

Здравствуйте, Денис.
Сначала считываем данные с листа в массив,
потом переставляем столбцы в массиве (оставляя только нужные, в требуемом порядке),
потом этот массив добавляем в нашу сводную таблицу.

Здравствуйте, Игорь!
Как сделать что бы программа брала из файлов, не все столбцы а те которые прописаны в программе.

А если щелкнуть по той ссылке, которую я дал в предыдущем комментарии,
и скопировать код этой функции оттуда? (первый же макрос в статье)

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

Для начала, выводите диалоговое окно выбора файла:
http://excelvba.ru/code/GetFileOrFolderPath

Например, вместо этого кода:

  Dim coll As Collection
    ' загружаем список файлов по маске имени файла
   Set coll = FilenamesCollection(InvoiceFolder$, "Заявка №*от*.xls*", 1)

пишете

Dim coll As New Collection
    ИмяФайла = GetFileName("Заголовок окна", ThisWorkbook.Path)   ' запрашиваем имя файла
    If ИмяФайла = "" Then Exit Sub    ' выход, если пользователь отказался от выбора файла
coll.add ИмяФайла 

PS: не забудьте добавить код функции GetFileName в свой файл

Вы не могли бы подсказать, что нужно убрать из кода, чтобы можно было бы выбрать один файл из папки, а не все? Заранее спасибо!

Ну так это совсем другой макрос нужен.
Готового решения для такой задачи у меня на сайте нет.
Оформляйте заказ - сделаем.

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

Чтобы из одного файла данные загружались? надо первую половину кода удалить...
А какой смысл использовать макрос сбора данных из файлов, если собирать-то, собственно, ничего не надо?
Смысл из одного файла в другой данные копировать макросом... это можно и макрорекордером записать макрос из 4 строк, или даже формулам воспользоваться...

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

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
 __     __ __        __  _____    ____           _ 
\ \ / / \ \ / / | ___| / ___| __ _ / |
\ \ / / \ \ /\ / / | |_ | | / _` | | |
\ V / \ V V / | _| | |___ | (_| | | |
\_/ \_/\_/ |_| \____| \__, | |_|
|_|
Введите код, изображенный в стиле ASCII-арт.

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

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