MyTetra Share
Делитесь знаниями!
Сбор данных из файлов Excel в заданной папке
30.12.2017
22:33
Текстовые метки: CombineFiles
Раздел: VBA - GetOpen

Сбор данных из файлов 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

Прикрепленные файлы:
Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования