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

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

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

Доброе утро, Игорь!
подскажите, пжл, как в вашем прикрепленном файле увеличить кол-во столбцов?
у вас отображается всего 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 строк, или даже формулам воспользоваться...

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

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

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

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

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

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