VBA макросы. От бессмыслицы к осмысленному. Ядро

Наверное, пару лет назад, я бы отдал многое за подобную статью. Тогда, я рыл интернет в поисках информации о структурировании VBA проекта, но толком ничего не находил.

Всех приветствую! Наливайте чай, нарезайте бутеры, потому что вас ждет длинное, нудное чтиво, с большим количеством кода.

Чтиво про рефакторинг кода.

дисклеймер

1. Весь представленный ниже код написан лично автором этой статьи.

2. Я никого не хочу оскорбить/унизить/обидеть.

3. Я не претендую на истину в последней инстанции, вы вольны поступать так, как вам заблагорассудится

Короче говоря, убирайте ножи и поехали рефакторить!

_{Полная версия представленного кода в конце статьи по ссылке на github.}

Что нужно-то?

Ну смотрите. Приходит к нам коллега из смежного отдела и говорит:
— У меня есть макрос, Вася Пупкин делал, который уволился сто лет назад. Так вот он чет не работает. Глянь, что случилось. Вот ТЗ изначальное:

Нужно из таблицы (пример ниже) вытащить уникальные строки с товарами количество которых или больше или меньше 20 (это я сам должен выбирать когда как), просуммировать дубли (не спрашивай зачем) и в этой же книге на новом листе выгрузить получившийся список. Саму книгу пересохранить с новым именем — ддммггччмм.xlsx. Вот.

Таблица (пример):

И дает нам файл 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

Небольшая ремарка:

1. Повторюсь, весь код в этой статье, включая bad пример, писал автор (т.е. я).

2. Пример небольшой, но нисколько не утрированный. Я встречал на практике проекты оформленные один в один таким образом, но строк было в десяток больше.

Ну чтош… закончили избиение, переходим к исправлению.

Создаем проект

Если кто-нибудь из вас писал код на другом языке, то первое с чем обычно все сталкиваются – создание и именование папки для будущего проекта.

Что с 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

1. Переменная DEV которую мы объявили в DevUtils модуле, дает возможность отрабатывать автодополнению.

2. Так как мы прописали директиву в настройках проекта, теперь мы можем управлять режимом: разработка / продакшн (ну допустим).

То есть, теперь мы можем один раз указать путь к файлу и использовать его постоянно при отладке, а когда все будет готово, просто переключаем в настройках директиву на 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

1. Добавляем On Error GoTo Catch и лейбл Catch для отлова ошибок.

2. Перед Catch ставим Exit Sub, чтобы не попасть в Catch после обычного завершения макроса (когда нет ошибок).

3. Перед Exit Sub добавляем лейбл ExitSub, а в Catch, после обработки ошибки, отправляемся на этот лейбл с помощью Resume ExitSub.

Поймали ошибку, обработали, вышли сухими и чистыми.

Ошибку будем просто отображать в 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 ValidatePath(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

Вызвали, проверили наличие ошибки, если есть, показали сообщение, чисто вышли.

Дальше по плану:

1. Открыть книгу

2. Проверить наличие нужных столбцов

3. Прочитать в массив

Ну вы же не думаете, что мы будем вот так просто брать и открывать книгу?

Делаем обертки

Сначала, создадим обертку для книги-отчета. Предположим, что отчет называется Отчет. Значит создаем класс модуль `ReportBook`. Проект сейчас выглядит как-то так, чуть позже раскидаем по папкам:

Минутка объяснения действий автора, которые последуют ниже. В VBA отсутствует понятие «конструктор». Есть один интересный паттерн Object Initialization. Но я использую свой собственный, который и будет ниже. Подробнее об этом писал в tg.

Для конструктора класса, создаем модуль ReportBookCstr, а в нем следующую функцию:

Public Function NewReportBook(ByVal Path As String) As ReportBook     Set NewReportBook = New ReportBook     NewReportBook.Path = Path End Function

1. Создаем инстанс класса ReportBook используя название функции, чтобы не создавать лишние переменные.

2. Устанавливаем свойство 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

1. Передаем имя столбца или массив имен + диапазон для поиска.

2. Если столбец найден, будет возвращена структура с корректным именем и индексом столбца.

3. В противном случае будет вызвана ошибка. Логику генерации сообщения выносим в отдельную функцию.

Указывать 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

В итоге, если не найден какой-либо столбец, мы будем получать следующее сообщение:

Дело за малым…

В модулях уже потеряться можно

А что у нас со структурой проекта?

В распределении по папкам четких правил нет, но есть некоторые моменты, которые лично я часто использую:

1. Помещать общие модули в папку Common.

2. Помещать класс с конструктором в одноименную классу папку.

3. Помещать весь проект в папку src.

В итоге получаем такой вид:

Пишем коллектор

Для коллектора так же создаем класс и конструктор GoodsCollector, но я еще больше хочу заморочиться.

Что у нас есть сейчас:
есть два стулакейса – больше 20 и меньше.

Но сегодня два, а «завтра» могут прийти и добавить новую логику, например больше 40.

Так вот, чтобы нам было проще масштабировать нашу невероятную архитектуру, сделаем следуюшее:

1. Напишем интерфейс IGoodsCollector.

2. Напишем для него две реализации GT20Collecor и LT20Collector (от Greater и Lower Than соответственно).

3. Воспользуемся паттерном фабрика для удобной инициализации.

С интерфейсом все дико просто. Создаем обычный класс, пишем в нем метод 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

Есть подозрение, что тут и комментарии не нужны, но все же:

1. В фабрику принимаем тип коллектора в качестве аргумента и далее в Select Case возвращаем необходимую реализацию.

2. В случае отсутствия реализации кидаем ошибку.

Теперь, если нам потребуется добавить новый коллектор, нам достаточно описать его логику и добавить в фабрику. В 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

1. Добавляем новый лист.

2. Итерируемся по списку товаров, получая Наименование товара с помощью KeySerializer.

3. Вносим имя и количество.

4. Генерируем новое имя файла и сохраняем книгу.

Для закрытия отчета, добавляем метод 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шника

Спасибо, что дочитали!?