Этот макрос предназначен для сбора (загрузки) информации из файлов 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