Главная » Макросы для Excel » Сбор данных из файлов Excel в заданной папке

Сбор данных из файлов 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 КБ
  • 185622 просмотра

Комментарии

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

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".
Сергей, 9 Ноя 2014 - 14:49.#1

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

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)

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

Сергей, 8 Ноя 2014 - 22:56.#2

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

Игорь (администратор сайта), 8 Ноя 2014 - 21:20.#3

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

 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 - транспонирование загруженного из очередного файла диапазона

Сергей, 8 Ноя 2014 - 18:42.#4

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

Игорь (администратор сайта), 8 Авг 2014 - 18:21.#5

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

Серафим, 8 Авг 2014 - 18:19.#6

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

Игорь (администратор сайта), 27 Июл 2014 - 16:48.#7

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

Алексей, 27 Июл 2014 - 11:18.#8

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

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

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

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

Гость, 6 Июн 2014 - 15:23.#9

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

Игорь (администратор сайта), 4 Июн 2014 - 14:40.#10

В макросе привязка не к имени листа, а к КОДОВОМУ ИМЕНИ ЛИСТА
оно меняется в редакторе 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
' ==== конец обработки данных из очередного файла

Honey, 4 Июн 2014 - 09:23.#11

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

Гость, 9 Окт 2013 - 12:02.#12

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

Гость, 9 Окт 2013 - 10:30.#13

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

Игорь (администратор сайта), 19 Сен 2013 - 09:28.#14

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

Денис, 19 Сен 2013 - 01:21.#15

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

Игорь (администратор сайта), 16 Сен 2013 - 20:23.#16

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

Денис, 16 Сен 2013 - 09:46.#17

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

Игорь (администратор сайта), 9 Апр 2013 - 19:09.#18

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

Гость, 9 Апр 2013 - 18:24.#19

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

Игорь (администратор сайта), 9 Апр 2013 - 11:52.#20

Для начала, выводите диалоговое окно выбора файла:
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 в свой файл

Гость, 9 Апр 2013 - 11:29.#21

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

Игорь (администратор сайта), 8 Апр 2013 - 13:59.#22

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

Гость, 8 Апр 2013 - 13:16.#23

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

Игорь (администратор сайта), 8 Апр 2013 - 12:08.#24

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

Гость, 8 Апр 2013 - 11:40.#25

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

Гость, 4 Апр 2013 - 21:37.#26

ООО-ч-ч-ч-ень было мне нужно 3 года назад. Но и сейчас интересно.
Спасибо за науку.

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

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

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

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