Наверное, пару лет назад, я бы отдал многое за подобную статью. Тогда, я рыл интернет в поисках информации о структурировании VBA проекта, но толком ничего не находил.
Всех приветствую! Наливайте чай, нарезайте бутеры, потому что вас ждет длинное, нудное чтиво, с большим количеством кода.
Чтиво про рефакторинг кода.
дисклеймер
Весь представленный ниже код написан лично автором этой статьи.
Я никого не хочу оскорбить/унизить/обидеть.
Я не претендую на истину в последней инстанции, вы вольны поступать так, как вам заблагорассудится
Короче говоря, убирайте ножи и поехали рефакторить!
Полная версия представленного кода в конце статьи по ссылке на github.
Что нужно-то?
Ну смотрите. Приходит к нам коллега из смежного отдела и говорит:
- У меня есть макрос, Вася Пупкин делал, который уволился сто лет назад. Так вот он чет не работает. Глянь, что случилось. Вот ТЗ изначальное:
Нужно из таблицы (пример ниже) вытащить уникальные строки с товарами количество которых или больше или меньше 20 (это я сам должен выбирать когда как), просуммировать дубли (не спрашивай зачем) и в этой же книге на новом листе выгрузить получившийся список. Саму книгу пересохранить с новым именем - ддммггччмм.xlsx. Вот.
Таблица (пример):
№ п/п | Артикул | Наименование | Единица | Количество |
1 | 123654 | Товар1 | кг | 20 |
2 | 654123 | Товар2 | шт | 15 |
И дает нам файл data.xlsx для разработки с таким вот содержимым:
Ну тут все ясно. Товарищ Пупкин захардкодил столбцы и приехали.
Открываем сам макрос. Первое что видим – интерфейс. Ну пользовательский, не побоюсь этого слова:
Набираем в грудь побольше воздуха и открываем VBE.
Не для слабонервных
Сначала смотрим в ProjectExplorer дабы ознакомится с содержимым, какие модули, классы есть...
Уже понимаете к чему все идет, да?
В редакторе сразу видим открытый модуль Лист1 и его код:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Address = "$B$1" Then With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = False .ButtonName = "Выбрать" .Show If .SelectedItems.Count > 0 Then Worksheets(1).Range("B1").Value = .SelectedItems.Item(1) Cancel = True End If End With End If End Sub
Ну в целом.. Ладно, переходим к логике.
Дамы и господа, Module1:
Sub Обработка() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim f As String, bm As Boolean Dim twb, workb As Workbook Dim sh As Worksheet Dim lr As Long, lc As Long, i As Long, ii As Long, iii As Long Dim arr Dim tovary_cotoryx_bolshe_than_20 As Object: Set tovary_cotoryx_bolshe_than_20 = CreateObject("Scripting.Dictionary") Dim tovary_cotoryx_menshe_chem_20 As Object: Set tovary_cotoryx_menshe_chem_20 = CreateObject("Scripting.Dictionary") Dim q, v, g Dim sh2 As Worksheet f = Sheets(1).Range("B1").Value bm = Sheets(1).Range("B2").Value = "0" If Len(f) = 0 Then MsgBox "Путь не указан!", vbCritical, "Ошибка" Exit Sub End If Set twb = ThisWorkbook Workbooks.Open f Set workb = ActiveWorkbook Set sh = workb.ActiveSheet If sh.Range("B1").Value <> "Артикул" And sh.Range("B1").Value <> "АРТИКУЛ" Then MsgBox "Не верный формат файла!", vbCritical, "Ошибка" Exit Sub End If If LCase(sh.Range("C1").Value) <> "наименование" Then MsgBox "Не верный формат файла!", vbCritical, "Ошибка" Exit Sub End If If sh.Range("E1").Value Like "*оличество" = False Then MsgBox "Не верный формат файла!", vbCritical, "Ошибка" Exit Sub End If lr = workb.ActiveSheet.Rows(Rows.Count).End(xlUp).Row lc = workb.ActiveSheet.Columns(Columns.Count).End(xlToLeft).Column arr = workb.ActiveSheet.Range(Cells(1, 1), Cells(lr, lc)).Value For i = 1 To lr If IsNumeric(arr(i, 5)) Then If arr(i, 5) > 20 Then If tovary_cotoryx_bolshe_than_20.Exists(arr(i, 2) & ";" & arr(i, 3)) = True Then q = tovary_cotoryx_bolshe_than_20(arr(i, 2) & ";" & arr(i, 3)) = arr(i, 5) tovary_cotoryx_bolshe_than_20(arr(i, 2) & ";" & arr(i, 3)) = q Else tovary_cotoryx_bolshe_than_20.Add arr(i, 2) & ";" & arr(i, 3), arr(i, 5) End If ElseIf arr(i, 5) = 0 Then Else If tovary_cotoryx_menshe_chem_20.Exists(arr(i, 2) & ";" & arr(i, 3)) = True Then q = tovary_cotoryx_menshe_chem_20(arr(i, 2) & ";" & arr(i, 3)) = arr(i, 5) tovary_cotoryx_menshe_chem_20(arr(i, 2) & ";" & arr(i, 3)) = q Else tovary_cotoryx_menshe_chem_20.Add arr(i, 2) & ";" & arr(i, 3), arr(i, 5) End If End If End If Next workb.Sheets.Add Set sh2 = workb.Sheets(1) If bm Then v = tovary_cotoryx_bolshe_than_20.Items() g = tovary_cotoryx_bolshe_than_20.Keys() Else v = tovary_cotoryx_menshe_chem_20.Items() g = tovary_cotoryx_menshe_chem_20.Keys() End If For ii = LBound(g) To UBound(g) sh2.Cells(ii + 1, 1).Value = Split(g(ii), ";")(0) sh2.Cells(ii + 1, 2).Value = Split(g(ii), ";")(1) Next For iii = LBound(v) To UBound(v) sh2.Cells(iii + 1, 3).Value = v(iii) Next workb.SaveAs twb.Path & "\" & Format(Now, "ddmmyyhhnn") & ".xlsx" workb.Close False MsgBox "Готово!", vbInformation, "Готово" Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub
Работает! © В.Пупкин
А давайте разбираться?
Даю вам 2 минуты на разбор кода в самостоятельном режиме, а после можете возвращаться и сравнить результаты. Время пошло...
Разобрались? Давайте сверяться.
Подробный разбор кода
Sub Обработка() ' Русское именование Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' Объявление всех переменных блоком в начале процедуры Dim f As String, bm As Boolean Dim twb, workb As Workbook ' не верное присвоение типов Dim sh As Worksheet Dim lr As Long, lc As Long, i As Long, ii As Long, iii As Long Dim arr ' использование русского транслита и английских слов Dim tovary_cotoryx_bolshe_than_20 As Object: Set tovary_cotoryx_bolshe_than_20 = CreateObject("Scripting.Dictionary") Dim tovary_cotoryx_menshe_chem_20 As Object: Set tovary_cotoryx_menshe_chem_20 = CreateObject("Scripting.Dictionary") Dim q, v, g Dim sh2 As Worksheet ' названия переменных не передают содержимое ' Неоднозначные присваивания, непонятно что передаем и зачем f = Sheets(1).Range("B1").Value bm = Sheets(1).Range("B2").Value = "0" If Len(f) = 0 Then MsgBox "Путь не указан!", vbCritical, "Ошибка" ' выход из процедуры без возврата ScreenUpdating и авторасчетов формул Exit Sub End If ' ненужное присвоение переменной значения ThisWorkBook Set twb = ThisWorkbook Workbooks.Open f Set workb = ActiveWorkbook Set sh = workb.ActiveSheet If sh.Range("B1").Value <> "Артикул" And sh.Range("B1").Value <> "АРТИКУЛ" Then MsgBox "Не верный формат файла!", vbCritical, "Ошибка" Exit Sub End If If LCase(sh.Range("C1").Value) <> "наименование" Then MsgBox "Не верный формат файла!", vbCritical, "Ошибка" Exit Sub End If If sh.Range("E1").Value Like "*оличество" = False Then MsgBox "Не верный формат файла!", vbCritical, "Ошибка" Exit Sub End If lr = workb.ActiveSheet.Rows(Rows.Count).End(xlUp).Row lc = workb.ActiveSheet.Columns(Columns.Count).End(xlToLeft).Column arr = workb.ActiveSheet.Range(Cells(1, 1), Cells(lr, lc)).Value For i = 1 To lr If IsNumeric(arr(i, 5)) Then If arr(i, 5) > 20 Then ' Большая вложенность ' Дублирование кода If tovary_cotoryx_bolshe_than_20.Exists(arr(i, 2) & ";" & arr(i, 3)) = True Then q = tovary_cotoryx_bolshe_than_20(arr(i, 2) & ";" & arr(i, 3)) = arr(i, 5) tovary_cotoryx_bolshe_than_20(arr(i, 2) & ";" & arr(i, 3)) = q Else tovary_cotoryx_bolshe_than_20.Add arr(i, 2) & ";" & arr(i, 3), arr(i, 5) End If ElseIf arr(i, 5) = 0 Then Else If tovary_cotoryx_menshe_chem_20.Exists(arr(i, 2) & ";" & arr(i, 3)) = True Then q = tovary_cotoryx_menshe_chem_20(arr(i, 2) & ";" & arr(i, 3)) = arr(i, 5) tovary_cotoryx_menshe_chem_20(arr(i, 2) & ";" & arr(i, 3)) = q Else tovary_cotoryx_menshe_chem_20.Add arr(i, 2) & ";" & arr(i, 3), arr(i, 5) End If End If End If Next workb.Sheets.Add Set sh2 = workb.Sheets(1) If bm Then v = tovary_cotoryx_bolshe_than_20.Items() g = tovary_cotoryx_bolshe_than_20.Keys() Else v = tovary_cotoryx_menshe_chem_20.Items() g = tovary_cotoryx_menshe_chem_20.Keys() End If For ii = LBound(g) To UBound(g) sh2.Cells(ii + 1, 1).Value = Split(g(ii), ";")(0) sh2.Cells(ii + 1, 2).Value = Split(g(ii), ";")(1) Next For iii = LBound(v) To UBound(v) sh2.Cells(iii + 1, 3).Value = v(iii) Next workb.SaveAs twb.Path & "\" & Format(Now, "ddmmyyhhnn") & ".xlsx" workb.Close False MsgBox "Готово!", vbInformation, "Готово" Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic ' Большое количество строк для одной процедуры ' Весь код в одной процедуре End Sub
Небольшая ремарка:
Повторюсь, весь код в этой статье, включая bad пример, писал автор (т.е. я).
Пример небольшой, но нисколько не утрированный. Я встречал на практике проекты оформленные один в один таким образом, но строк было в десяток больше.
Ну чтош... закончили избиение, переходим к исправлению.
Создаем проект
Если кто-нибудь из вас писал код на другом языке, то первое с чем обычно все сталкиваются – создание и именование папки для будущего проекта.
Что с VBA? Не поверите, но по сути, тоже самое!
Создаем книгу, переходим в VBE, в ProjectExplorer жмем правой кнопкой по нашему новому проекту, выбираем пункт VBAProject properties... и придумываем, таки, название, господа!
(картинка с просторов интернета)
Что делает макрос? Консолидирует товары опираясь на количество. Я придумал GoodsCollector в качестве названия, хотя, возможно, это не самый лучший вариант, но куда лучше стандартного VBAProject...
Единственное, что еще делаю я, но не обязательно делать никому – добавляю в конце слово Project, чтобы в случае если у меня будет одноименный проекту класс, vba не ругался.
Создаем точку входа
Не поверите, но очень часто бывает так, что в проекте может быть несколько модулей. Невероятно, скажите вы! Поразительно, поддакну я!
И когда они при этом неоднозначно названы, порой сложно найти входную процедуру. Перефразируя слова классика: ну не чтобы по факту сложно, но по сути сложно.
Так вот, чтобы избежать подобных казусов, создаем модуль App, а в нем процедуру Main.
На самом деле, можно назвать модуль Index, Program, как хотите. Главное чтобы любой человек, который не шарит в вашем проекте молниеносно смог понять где точка входа.
Т.к. я пользуюсь надстройкой Rubberduck, я взял за правило убирать элементы Excel, например Лист1 или ЭтаКнига, в соответствующую папку:
Начнемс
А начнем мы с помощи себе как разработчику.
Создаем модуль DevUtils и наполняем его таким содержимым:
'@Folder("GoodsCollectorProject") Option Explicit Public DEV As Boolean
Обычно, если мне требуются какие-либо скрытые листы, я так же добавляю сюда процедуру Public Sub DevMode(ByVal State As Boolean), в которой эти листы либо скрываю, либо показываю. Запуск процедуры выполняю в местной консоли (Immediate Window):
Но в данном случае обойдемся публичной переменной DEV.
Позже поймете зачем она.
Еще, нужно пройти в настройки проекта и прописать в Conditional Compilation Arguments строчку DEV = 1, тем самым мы, как бы, включим режим для разработки:
А вот теперь...
Рефакторим
Первым делом нам нужно получить путь к отчету. Мы обязательно сделаем UserForm'у для всех настроек, но чуть позже. Поэтому пока пишем так:
Public Sub Main() #If DEV Then Const FilePath As String = "C:\dev\projects\vba\refact\data.xlsx" #Else Dim FilePath As String ' TODO: логика получения пути #End If End Sub
Переменная
DEVкоторую мы объявили вDevUtilsмодуле, дает возможность отрабатывать автодополнению.Так как мы прописали директиву в настройках проекта, теперь мы можем управлять режимом: разработка / продакшн (ну допустим).
То есть, теперь мы можем один раз указать путь к файлу и использовать его постоянно при отладке, а когда все будет готово, просто переключаем в настройках директиву на DEV = 0 и применяем, тем самым, продакшн мод (��ак скааать).
(картинка с просторов интернета)
По тексту оригинала у нас идет отключение мельканий экрана и авторасчетов (ну надо, так надо).
Проблема в том, что отключение этих настроек идет в самом начале, а включение в самом конце, и тем самым при некорректном выходе или выходе с помощью Exit Sub эти настройки не включаются.
Исправим это таким вот образом:
On Error GoTo Catch #If DEV Then Const FilePath As String = "C:\dev\projects\vba\refact\data.xlsx" #Else Dim FilePath As String ' TODO: логика получения пути #End If ExitSub: ' Чистый выход Exit Sub Catch: ' Ловим ошибку Resume ExitSub
Добавляем
On Error GoTo Catchи лейблCatchдля отлова ошибок.Перед
CatchставимExit Sub, чтобы не попасть вCatchпосле обычного завершения макроса (когда нет ошибок).Перед
Exit Subдобавляем лейблExitSub, а вCatch, после обработки ошибки, отправляемся на этот лейбл с помощьюResume ExitSub.
Почему Resume, э?
Использование
Gotoне очищает объект Err (необходимо использоватьErr.Clear) и оставляет ваш обработчик ошибок отключенным. Если ошибка возникает после метки, она не будет обработана.Использование
Resumeочищает объект Err и снова включает обработчик ошибок (он отключен во время обработки ошибок). Если ошибка возникает послеCleanupметки, она будет обработана вErroHandler
(c) StackOverflow
Поймали ошибку, обработали, вышли сухими и чистыми.
Ошибку будем просто отображать в MsgBox и прописывать в вбансоль (Immediate Window). При необходимости подключаем логгер и логируем ошибку.
Catch: ' Ловим ошибку Call MsgBox( _ "Критическая ошибка." & vbNewLine & vbNewLine & Err.Description, _ vbCritical, _ "Ошибка выполнения" _ ) ' Использую здесь Call, чтобы можно было аргументы прописать в скобках, ' просто для "красоты" Debug.Print "#" & Err.Number, Err.Description Resume ExitSub
Идем дальше?
Создаем модуль Utils, в который мы будем помещать всякие вспомогашки.
И помещаем туда две функции:
' Модуль Utils Public Sub DisableSettings() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual End Sub Public Sub EnableSetting() Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub
Добавляем их в Main:
On Error GoTo Catch Utils.DisableSettings #If DEV Then Const FilePath As String = "C:\dev\projects\vba\refact\data.xlsx" #Else Dim FilePath As String ' TODO: логика получения пути #End If ExitSub: ' Чистый выход Utils.EnableSetting Exit Sub Catch: ' Ловим ошибку GoTo ExitSub
Далее по списку оригинала объявление переменных.
(картинка с просторов интернета)
Это очень плохая практика – объявление всех переменных блоком в начале процедуры. Всегда лучше объявлять их непосредственно перед первым использованием.
Далее проверяем путь. Проверку мы можем выделить в отдельный модуль. Назовем его PathChecker и добавим функцию Validate, которая будет возвращать...хм, кое-что интересное. Хочу немного поэкспериментировать, че бы нет, кто мне запретит:
Public Function Validate(ByVal Path As String) As TCheckResult
Короче, создаем модуль CheckerTypes и прописываем UDT:
Public Type TCheckResult HasError As Boolean Message As String End Type
А теперь логику:
Public Function Validate(ByVal Path As String) As TCheckResult If Len(Path) = 0 Then Validate.HasError = True Validate.Message = "Путь не указан." Exit Function End If Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject") If Not FSO.FileExists(Path) Then Validate.HasError = True Validate.Message = "Файл не существует или передан не корректный путь." Exit Function End If End Function
Можно добавить еще сколько угодно проверок. По вкусу.
Вот только, мне не очень нравится создание FSO. Не красиво. Давайте в Utils добавим что-то типа конструктора:
' Модуль Utils Public Function NewFileSystemObject() As Object Set NewFileSystemObject = CreateObject("Scripting.FileSystemObject") End Function ' Модуль PathChecker Public Function Validate(ByVal Path As String) As TCheckResult If Len(Path) = 0 Then Validate.HasError = True Validate.Message = "Путь не указан." Exit Function End If Dim FSO As Object: Set FSO = Utils.NewFileSystemObject() ' Так лучше If Not FSO.FileExists(Path) Then Validate.HasError = True Validate.Message = "Файл не существует или передан не корректный путь." Exit Function End If End Function
В Main пользуемся новоиспеченной проверкой:
Dim Result As TCheckResult: Result = PathChecker.Validat(FilePath) If Result.HasError Then MsgBox Result.Message, vbExclamation, "Ошибка пути к файлу" GoTo ExitSub End If ExitSub: ' Чистый выход Utils.EnableSetting Exit Sub
Там Resume, тут GoTo, ну это че такое?
Вызвали, проверили наличие ошибки, если есть, показали сообщение, чисто вышли.
(картинка с просторов интернета)
Дальше по плану:
Открыть книгу
Проверить наличие нужных столбцов
Прочитать в массив
Ну вы же не думаете, что мы будем вот так просто брать и открывать книгу?
Делаем обертки
Сначала, создадим обертку для книги-отчета. Предположим, что отчет называется Отчет. Значит создаем класс модуль `ReportBook`. Проект сейчас выглядит как-то так, чуть позже раскидаем по папкам:
Минутка объяснения действий автора, которые последуют ниже. В VBA отсутствует понятие "конструктор". Есть один интересный паттерн Object Initialization. Но я использую свой собственный, который и будет ниже. Подробнее об этом писал в tg.
Для конструктора класса, создаем модуль ReportBookCstr, а в нем следующую функцию:
Public Function NewReportBook(ByVal Path As String) As ReportBook Set NewReportBook = New ReportBook NewReportBook.Path = Path End Function
Создаем инстанс класса
ReportBookиспользуя название функции, чтобы не создавать лишние переменные.Устанавливаем свойство
Path.
Стандартный конструктор, типа.
В самом классе создаем приватный udt для приватных полей, публичное свойство Path и заготовку под методы Validate и GetData:
Option Explicit Private Type TReportBook Book As Workbook Path As String End Type Private this As TReportBook Public Property Get Path() As String Path = this.Path End Property Public Property Let Path(ByVal RHS As String) this.Path = RHS End Property Public Function Validate() As TCheckResult End Function Public Function GetData() As Variant End Function
Валидировать будем проверяя наличие нужных столбцов.
Парсим столбцы
Для парсинга столбцов создадим модуль ColumnTypes, небольшую структурку TColumn и функцию FindColumn:
Option Explicit Public Type TColumn Name As String Index As Integer End Type Public Function FindColumn(ByRef NameOrNames As Variant, ByRef Table As Range) As TColumn Dim Names As Variant If IsArray(NameOrNames) Then Names = NameOrNames Else Names = Array(NameOrNames) Dim Name As Variant For Each Name In Names Dim FoundCell As Range: Set FoundCell = Table.Find( _ What:=Name, _ LookIn:=XlFindLookIn.xlValues, _ Lookat:=XlLookAt.xlWhole, _ MatchCase:=False _ ) If Not FoundCell Is Nothing Then FindColumn.Name = FoundCell.Value FindColumn.Index = FoundCell.Column Exit Function End If Next Dim ErrMsg As String ErrMsg = GenerateErrMsg(Names, Table.Parent.Parent) Call Err.Raise( _ Number:=9, _ Source:="FindColumn", _ Description:=ErrMsg _ ) End Function Public Function GenerateErrMsg(ByRef Names As Variant, ByRef Book As Workbook) GenerateErrMsg = "В книге '" & Book.Name & "' не удалось найти имя столбца по ключевым словам:" & _ vbNewLine & Strings.Join(Names, vbNewLine) End Function
Передаем имя столбца или массив имен + диапазон для поиска.
Если столбец найден, будет возвращена структура с корректным именем и индексом столбца.
В противном случае будет вызвана ошибка. Логику генерации сообщения выносим в отдельную функцию.
Указывать
Sourceпри вызове ошибки является хорошей практикой.
Параметры методы Find можно настроить по своему усмотрению (или вынести их как параметры функции FindColumn, например). Для текущего кейса хватит этих.
А теперь создаем класс ReportColumns с конструктором и применяем нашу функцию:
' Модуль ReportColumnsCstr Public Function NewReportColumns(ByRef Table As Range) As ReportColumns Set NewReportColumns = New ReportColumns NewReportColumns.RegisterColumns Table End Function ' Класс ReportColumns Option Explicit Private Type TReportColumns Item As TColumn Name As TColumn Quantity As TColumn End Type Private this As TReportColumns Public Property Get Item() As TColumn Item = this.Item End Property Public Property Get Name() As TColumn Name = this.Name End Property Public Property Get Quantity() As TColumn Quantity = this.Quantity End Property Public Sub RegisterColumns(ByRef Table As Range) this.Item = ColumnTypes.FindColumn("Артикул", Table) this.Name = ColumnTypes.FindColumn("Наименование", Table) this.Quantity = ColumnTypes.FindColumn(Array( _ "Количество", _ "Кол-во", _ "Кол." _ ), Table) End Sub
Здесь в конструкторе вызывается метод
RegisterColumns, что не является хорошей практикой (выполнять логику в конструкторе не желательно), но все что он делает – присваивает свойствам значения, поэтому сомнительно, но окэй.
Пишем реализацию метода ReportBook.Validate:
Private Type TReportBook Book As Workbook Path As String Columns As ReportColumns ' Добавили приватное поле Columns End Type Private this As TReportBook Public Property Get Path() As String Path = this.Path End Property Public Property Let Path(ByVal RHS As String) this.Path = RHS End Property Public Function Validate() As TCheckResult Set this.Book = Workbooks.Open(this.Path) On Error GoTo Catch Set this.Columns = NewReportColumns(this.Book.ActiveSheet.UsedRange) Exit Function Catch: Validate.HasError = True Validate.Message = Err.Description Resume Next ' При ошибке, выполняем присваивание необходимой инфы и продолжаем выполнение End Function
Так как мы прописали в FindColumn вызов ошибки, нам достаточно ее отловить и записать в результат. Вот и вся валидация.
Дописываем в Main новый кусочек:
Dim Result As TCheckResult: Result = PathChecker.Validate(FilePath) If Result.HasError Then MsgBox Result.Message, vbExclamation, "Ошибка пути к файлу" GoTo ExitSub End If Dim Book As ReportBook: Set Book = NewReportBook(FilePath) ' Инициализируем объект класса ReportBook Result = Book.Validate() ' Валидируем и проверяем ошибку If Result.HasError Then MsgBox Result.Message, vbExclamation, "Ошибка файла" GoTo ExitSub End If ExitSub: ' Чистый выход Utils.EnableSetting Exit Sub
В итоге, если не найден какой-либо столбец, мы будем получать следующее сообщение:
Дело за малым...
В модулях уже потеряться м��жно
А что у нас со структурой проекта?
В распределении по папкам четких правил нет, но есть некоторые моменты, которые лично я часто использую:
Помещать общие модули в папку Common.
Помещать класс с конструктором в одноименную классу папку.
Помещать весь проект в папку src.
В итоге получаем такой вид:
Пишем коллектор
Для коллектора так же создаем класс и конструктор GoodsCollector, но я еще больше хочу заморочиться.
Что у нас есть сейчас:
есть два стулакейса – больше 20 и меньше.
(картинка с просторов интернета)
Но сегодня два, а "завтра" могут прийти и добавить новую логику, например больше 40.
Так вот, чтобы нам было проще масштабировать нашу невероятную архитектуру, сделаем следуюшее:
Напишем интерфейс
IGoodsCollector.Напишем для него две реализации
GT20CollecorиLT20Collector(от Greater и Lower Than соответственно).Воспользуемся паттерном фабрика для удобной инициализации.
С интерфейсом все дико просто. Создаем обычный класс, пишем в нем метод Collect без реализации и для красоты с помощью Rubberduck помечаем аннотацией:
'@Interface '@Folder "GoodsCollectorProject.src.Core.GoodsCollector" Option Explicit Public Function Collect() As Object End Function
Далее пишем реализацию. Я покажу пример для кейса "больше 20", т.к. "меньше 20" в целом такой же.
' Класс GT20Collector '@Folder "GoodsCollectorProject.src.Core.GoodsCollector.GT20Collector" Option Explicit Implements IGoodsCollector Private Type TGT20Collector Data As Variant Columns As ReportColumns End Type Private this As TGT20Collector Public Property Get Data() As Variant Data = this.Data End Property Public Property Let Data(ByVal RHS As Variant) this.Data = RHS End Property Public Property Get Columns() As ReportColumns Set Columns = this.Columns End Property Public Property Set Columns(ByVal RHS As ReportColumns) Set this.Columns = RHS End Property Public Function Collect() As Object Dim Goods As Object: Set Goods = NewDictionary() Dim Row As Long For Row = LBound(this.Data, 1) To UBound(this.Data, 1) Dim Quantity As Variant: Quantity = Data(Row, this.Columns.Quantity.Index) If Not IsNumeric(Quantity) Then GoTo Continue If Not Quantity > 20 Then GoTo Continue Dim Key As String: Key = GenerateKey(Row) Goods(Key) = Goods(Key) + Quantity Continue: Next Set Collect = Goods End Function Public Function GenerateKey(ByVal Row As Long) As String Dim KeyData As Variant: KeyData = Array( _ this.Data(Row, this.Columns.Item.Index), _ this.Data(Row, this.Columns.Name.Index) _ ) GenerateKey = KeySerializer.Stringify(KeyData) End Function Private Function IGoodsCollector_Collect() As Object Set IGoodsCollector_Collect = Collect() End Function
Заметили конструктор объекта Dictionary?
' Модуль Utils Public Function NewDictionary() As Object Set NewDictionary = CreateObject("Scripting.Dictionary") End Function
Основная логика у нас лежит в методе Collect. По сути мы делаем тоже самое, что и в коде Василия, но немного более осознанно. Особое внимание обратите на метод GenerateKey. Можно для простоты, действительно, написать так же как Вася, но мы сделаем логику формирования ключа более универсальной и вынесем ее в отдельный модуль:
' Модуль KeySerialize '@Folder("GoodsCollectorProject.src.Common") Option Explicit Const SEPARATOR As String = ";" Public Function Stringify(ByRef KeyData As Variant) As String Stringify = Strings.Join(KeyData, SEPARATOR) End Function Public Function Parse(ByVal Key As String) As Variant Parse = Strings.Split(Key, SEPARATOR) End Function
Тут два простейших метода – сделать строку, вернуть из строки. Но использовать их теперь куда удобнее и понятнее.
Про конструктор не забываем:
Public Function NewGT20Collector(ByRef Data As Variant, ByRef Columns As ReportColumns) As GT20Collector Set NewGT20Collector = New GT20Collector NewGT20Collector.Data = Data Set NewGT20Collector.Columns = Columns End Function
Теперь создаем два модуля: CollectorTypes и GoodsCollectorFactory:
' Модуль CollectorTypes ' Здесь перечисляем возможные варианты сборщиков Public Enum CollectorKind GT20 LT20 End Enum ' Модуль GoodsCollectorFactory Public Function GetCollector(ByVal Kind As CollectorKind, ByRef Data As Variant, ByRef Columns As ReportColumns) As IGoodsCollector Select Case Kind Case CollectorKind.GT20 Set GetCollector = NewGT20Collector(Data, Columns) Case CollectorKind.LT20 Set GetCollector = NewLT20Collector(Data, Columns) Case Else Call Err.Raise( _ Number:=9, _ Source:="GetCollector", _ Description:="Не удалось определить тип сборщика: " & Kind _ ) End Select End Function
Есть подозрение, что тут и комментарии не нужны, но все же:
В фабрику принимаем тип коллектора в качестве аргумента и далее в Select Case возвращаем необходимую реализацию.
В случае отсутствия реализации кидаем ошибку.
Теперь, если нам потребуется добавить новый коллектор, нам достаточно описать его логику и добавить в фабрику. В Main останется нетронутым такой код (кстати, ReportBook чуть допишем):
' Модуль App Dim Collector As IGoodsCollector ' Определяем коллектор, обязательно с типом интерфейса IGoodsCollector Set Collector = GoodsCollectorFactory.GetCollector( _ Kind, Book.GetData(), Book.Columns _ ) ' Запускаем фабрику и получаем нужную реализацию Dim Goods As Object: Set Goods = Collector.Collect() ' Вызываем единственный метод Collect ' Класс ReportBook ' Добавим публичное read-only свойство Columns Public Property Get Columns() As ReportColumns Set Columns = this.Columns End Property Public Property Get Path() As String Path = this.Path End Property Public Property Let Path(ByVal RHS As String) this.Path = RHS End Property Public Function Validate() As TCheckResult Set this.Book = Workbooks.Open(this.Path) On Error GoTo Catch Set this.Columns = NewReportColumns(this.Book.ActiveSheet.UsedRange) Exit Function Catch: Validate.HasError = True Validate.Message = Err.Description Resume Next End Function ' И реализуем функцию GetData Public Function GetData() As Variant GetData = this.Book.ActiveSheet.UsedRange.Value End Function
Ну и добавим метод сохранения данных в ReportBook, чтобы уже совсем было хорошо:
Public Sub SaveData(ByRef Goods As Object) Dim DataSheet As Worksheet: Set DataSheet = this.Book.Worksheets.Add() Dim Key As Variant For Each Key In Goods Dim Name As String: Name = KeySerializer.Parse(Key)(1) Dim Quantity As Long: Quantity = Goods(Key) Dim Row As Long: Row = Row + 1 DataSheet.Cells(Row, 1).Value = Name DataSheet.Cells(Row, 2).Value = Quantity Next Dim FileName As String: FileName = GenerateFileName() this.Book.SaveAs FileName End Sub Public Sub CloseReport() this.Book.Close SaveChanges:=False End Sub Private Function GenerateFileName() As String Dim FSO As Object: Set FSO = NewFileSystemObject() Dim FileName As String: FileName = Strings.Format(DateTime.Now, "ddmmyyhhnn") & ".xlsx" GenerateFileName = FSO.BuildPath(this.Book.Path, FileName) End Function
Добавляем новый лист.
Итерируемся по списку товаров, получая Наименование товара с помощью
KeySerializer.Вносим имя и количество.
Генерируем новое имя файла и сохраняем книгу.
Для закрытия отчета, добавляем метод CloseReport (Close зарезервировано).
Dim Goods As Object: Set Goods = Collector.Collect() Book.SaveData Goods Book.CloseReport MsgBox "Данные успешно сформированы.", vbInformation, "Выполнено" ExitSub: ' Чистый выход Utils.EnableSetting Exit Sub
Итог ядра проекта
Не поверите, но мы закончили с логикой. Можем поздравить себя.
Небольшая статистика того что получилось:
18 модулей против 1 у Васи
~380 строк кода (из них можно смело вычесть примерно 20 строк, т.к. это атрибуты Rubberduck) против ~100 у Васи
Правда во всей этой истории еще не хватает интерфейса пользователя.
Пользоваться таким подходом или нет, конечно, решать вам. Я лишь хотел продемонстрировать, что в VBA можно строить удобную для расширения и поддержания структуру. И, есессно, это далеко не идеальный вариант.
Конечно, для такого мелкого проекта это, скорее, too much. Но все познается в сравнении. Я много раз сталкивался с тем, что такие мелкие проекты разрастались до невозможных размеров и если заранее не была продумана структура (почти всегда это код подобный коду Васи), было довольно сложно его поддерживать.
Код из статьи: GitHub
Мой телеграм: Дневник VBAшника
Спасибо, что дочитали!?
