Пакетная обработка отчетов
В задачах автоматизации массовых обработок часто стоит задача обработки множества отчетов однотипным образом (разные подразделения, филиалы). Чтобы не обрабатывать каждый такой отчет отдельно можно создать типовой обработчик одного файла, а затем вставить его в процедуру обработки множества файлов.
Приведем пример. Нам нужно обработать файлы Продажи блюд производства с отгрузками по 20-ти ГМ. Их можно выгрузить в одну папку, добавив в конце имени файла название города или ГМ и запустить макрос, который обработает все 20 файлов без участия пользователя.
Ранее мы уже разработали обработчик одного файла под названием Simple_Relise. Теперь Необходимо вставить его в макрос, который пройдет по всем файлам в папке и применит к ним этот обработчик.
Приведем код. Запускать его нужно из любого файла НЕ находящегося в этой папке.
Sub ГрупповаяОбработка()
' запрашиваем пути к папкам с файлами, функция открывает окно выбора папки
InvoiceFolder$ = GetFolderPath
Dim coll As Collection
' загружаем список файлов по маске имени файла
'маска означает не полное имя файла, а лишь его постоянную часть
'как видно из примера на конце имени стоят звездочки - благодаря им мы имеем возможность
' дописывать города для отчетов
Set coll = FilenamesCollection(InvoiceFolder$, "Продажи блюд производства (с отгрузками)*.xls*", 1)
Dim WB As Workbook, sh As Worksheet, ra As Range
Application.ScreenUpdating = False ' отключаем обновление экрана (чтобы процесс открытия файлов не был виден)
' перебираем все найденные в папке файлы
For Each Filename In coll
Set WB = Nothing: Set WB = Workbooks.Open(Filename)
If WB Is Nothing Then
Pi.Log vbTab & "ОШИБКА при загрузке файла. Файл не обработан."
Else ' файл успешно открыт
'ВЫЗЫВАЕМ НАШУ ПРОЦЕДУРУ ОБРАБОТКИ ОДНОГО ФАЙЛА
Simple_Relise
WB.Close SaveChanges:=True ' закрываем обработанный файл
End If
Next
Application.ScreenUpdating = True
' Выводим сообщение по окончании работы
MsgBox "Обработка файлов завершена", vbInformation
End Sub
Чтобы код сработал добавляем в этот же модуль несколько функций, необходимых для работы. Функция отличается от макроса тем, что не является самостоятельной программой, приводящей к конечным преобразованиям. Они лишь выполняют отдельные операции, необходимые для макросов.
Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
Optional ByVal SearchDeep As Long = 999) As Collection
' Получает в качестве параметра путь к папке FolderPath,
' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
' Возвращает коллекцию, содержащую полные пути найденных файлов
' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)
Set FilenamesCollection = New Collection ' создаём пустую коллекцию
Set FSO = CreateObject("Scripting.FileSystemObject") ' создаём экземпляр FileSystemObject
GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск
Set FSO = Nothing: Application.StatusBar = False ' очистка строки состояния Excel
End Function
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
' перебор папок осуществляется в том случае, если SearchDeep > 1
' добавляет пути найденных файлов в коллекцию FileNamesColl
On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
If Not curfold Is Nothing Then ' если удалось получить доступ к папке
' Application.StatusBar = "Поиск в папке: " & FolderPath
For Each fil In curfold.Files ' перебираем все файлы в папке FolderPath
If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
Next
SearchDeep = SearchDeep - 1 ' уменьшаем глубину поиска в подпапках
If SearchDeep Then ' если надо искать глубже
For Each sfol In curfold.SubFolders ' перебираем все подпапки в папке FolderPath
GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
Next
End If
Set fil = Nothing: Set curfold = Nothing ' очищаем переменные
End If
End Function
Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", _
Optional ByVal InitialPath As String = "c:\") As String
' функция выводит диалоговое окно выбора папки с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает полный путь к выбранной папке, или пустую строку в случае отказа от выбора
Dim PS As String: PS = Application.PathSeparator
With Application.FileDialog(msoFileDialogFolderPicker)
If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
.ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
If .Show <> -1 Then Exit Function
GetFolderPath = .SelectedItems(1)
If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
End With
End Function
Данный код можно сохранить в ранее сформированный файл Учет Производства ( в новый обычный модуль) и дописать код установки меню следующей конструкцией:
With .Controls.Add
'отображаемый текст кнопки
.Caption = "Групповая обработка отчетов себестоимость комплексов"
'стиль кнопки доступные стили: 1 - только значек(16x16) 2 - только текст 3 - картинка и текст
.Style = 2
.FaceId = 2
'имя макроса, который будет выполнен при нажатии кнопки
.OnAction = "ГрупповаяОбработка"
End With
Затем сохраните файл. Зайти в меню Файл - Надстройки - Перейти. Снимите галочку со значения "Учет Производства", нажмите "ОК". Затем сохраните текущий файл как надстройку xlam в ту же папку, заменив старый. Закройте файл. Откройте файл, из которого будете запускать отчет и заново подключите надстройку. В итоге у вас в меню появится этот обработчик:
Приведем пример. Нам нужно обработать файлы Продажи блюд производства с отгрузками по 20-ти ГМ. Их можно выгрузить в одну папку, добавив в конце имени файла название города или ГМ и запустить макрос, который обработает все 20 файлов без участия пользователя.
Ранее мы уже разработали обработчик одного файла под названием Simple_Relise. Теперь Необходимо вставить его в макрос, который пройдет по всем файлам в папке и применит к ним этот обработчик.
Sub ГрупповаяОбработка()
' запрашиваем пути к папкам с файлами, функция открывает окно выбора папки
InvoiceFolder$ = GetFolderPath
Dim coll As Collection
' загружаем список файлов по маске имени файла
'маска означает не полное имя файла, а лишь его постоянную часть
'как видно из примера на конце имени стоят звездочки - благодаря им мы имеем возможность
' дописывать города для отчетов
Set coll = FilenamesCollection(InvoiceFolder$, "Продажи блюд производства (с отгрузками)*.xls*", 1)
Dim WB As Workbook, sh As Worksheet, ra As Range
Application.ScreenUpdating = False ' отключаем обновление экрана (чтобы процесс открытия файлов не был виден)
' перебираем все найденные в папке файлы
For Each Filename In coll
Set WB = Nothing: Set WB = Workbooks.Open(Filename)
If WB Is Nothing Then
Pi.Log vbTab & "ОШИБКА при загрузке файла. Файл не обработан."
Else ' файл успешно открыт
'ВЫЗЫВАЕМ НАШУ ПРОЦЕДУРУ ОБРАБОТКИ ОДНОГО ФАЙЛА
Simple_Relise
WB.Close SaveChanges:=True ' закрываем обработанный файл
End If
Next
Application.ScreenUpdating = True
' Выводим сообщение по окончании работы
MsgBox "Обработка файлов завершена", vbInformation
End Sub
Чтобы код сработал добавляем в этот же модуль несколько функций, необходимых для работы. Функция отличается от макроса тем, что не является самостоятельной программой, приводящей к конечным преобразованиям. Они лишь выполняют отдельные операции, необходимые для макросов.
Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
Optional ByVal SearchDeep As Long = 999) As Collection
' Получает в качестве параметра путь к папке FolderPath,
' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
' Возвращает коллекцию, содержащую полные пути найденных файлов
' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)
Set FilenamesCollection = New Collection ' создаём пустую коллекцию
Set FSO = CreateObject("Scripting.FileSystemObject") ' создаём экземпляр FileSystemObject
GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск
Set FSO = Nothing: Application.StatusBar = False ' очистка строки состояния Excel
End Function
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
' перебор папок осуществляется в том случае, если SearchDeep > 1
' добавляет пути найденных файлов в коллекцию FileNamesColl
On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
If Not curfold Is Nothing Then ' если удалось получить доступ к папке
' Application.StatusBar = "Поиск в папке: " & FolderPath
For Each fil In curfold.Files ' перебираем все файлы в папке FolderPath
If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
Next
SearchDeep = SearchDeep - 1 ' уменьшаем глубину поиска в подпапках
If SearchDeep Then ' если надо искать глубже
For Each sfol In curfold.SubFolders ' перебираем все подпапки в папке FolderPath
GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
Next
End If
Set fil = Nothing: Set curfold = Nothing ' очищаем переменные
End If
End Function
Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", _
Optional ByVal InitialPath As String = "c:\") As String
' функция выводит диалоговое окно выбора папки с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает полный путь к выбранной папке, или пустую строку в случае отказа от выбора
Dim PS As String: PS = Application.PathSeparator
With Application.FileDialog(msoFileDialogFolderPicker)
If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
.ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
If .Show <> -1 Then Exit Function
GetFolderPath = .SelectedItems(1)
If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
End With
End Function
Данный код можно сохранить в ранее сформированный файл Учет Производства ( в новый обычный модуль) и дописать код установки меню следующей конструкцией:
With .Controls.Add
'отображаемый текст кнопки
.Caption = "Групповая обработка отчетов себестоимость комплексов"
'стиль кнопки доступные стили: 1 - только значек(16x16) 2 - только текст 3 - картинка и текст
.Style = 2
.FaceId = 2
'имя макроса, который будет выполнен при нажатии кнопки
.OnAction = "ГрупповаяОбработка"
End With
Затем сохраните файл. Зайти в меню Файл - Надстройки - Перейти. Снимите галочку со значения "Учет Производства", нажмите "ОК". Затем сохраните текущий файл как надстройку xlam в ту же папку, заменив старый. Закройте файл. Откройте файл, из которого будете запускать отчет и заново подключите надстройку. В итоге у вас в меню появится этот обработчик:
Комментарии
Отправить комментарий