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

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