Background
: Я создал макрос несколько лет назад, и когда я просматривал его сейчас, это было трудно понять. Недавно я просмотрел все статьи из RubberduckVBA и начал узнавать, что VBA также может быть объектно-ориентированным языком, и я попытался реализовать эту концепцию в своем макросе.
Purpose of Macro
: у нас есть новые файлы каждый месяц, мы добавляем несколько столбцов в конец файла и даем свои комментарии. В следующем месяце мы снова использовали для извлечения комментариев с помощью concat и vlookup, но затем я создал быстрый макрос, чтобы он напрямую извлекал все данные. Он проверяет все рабочие листы, сравнивает с файлом предыдущих месяцев и извлекает лишние столбцы из старого файла.
Example
: У нас 8 столбцов в Sheet1
+ 4 колонки для комментариев. 12 колонка в Sheet2
+ 5 колонок комментариев. Макрос проверяет последний столбец в текущем файле и базу данных, которая динамически копирует последние 4 и 5 столбцов в соответствующий лист на основе конкатенированного значения всей строки в текущем / новом файле.
Примечание: Я копирую весь диапазон, так как нам также нужно извлечь форматирование чисел, формулу из предыдущего файла.
Request
: Макрос работает нормально в обоих форматах, я хотел бы знать, что я пропустил или что можно обновить в текущей версии макроса, чтобы сделать его более объектно-ориентированным.
Ниже приводится предыдущий процедурный макрос.
Option Explicit
Public Sub CarryForwardOld()
'Declare and set variables
'Add/check Tools> Reference> Microsoft Scripting Runtime
Dim ReadingRange As String
Dim dict As Scripting.Dictionary
Set dict = New Scripting.Dictionary
'Set screenupdating to false to increase the speed of processing
'Application.Calculation = xlCalculationAutomatic
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableCancelKey = xlInterrupt
Dim wbCurrent As Workbook
Set wbCurrent = ActiveWorkbook
Dim getfile As String
getfile = selectedfile(wbCurrent.Name)
If getfile = vbNullString Then Exit Sub
Dim wbOld As Workbook
Set wbOld = Workbooks(getfile)
If Not wbOld Is Nothing Then
If wbOld.Name = wbCurrent.Name Then
MsgBox "Both file names canot be same! System cannot distinguish between old and new file.", vbCritical, "Rename Either of the File"
Exit Sub
End If
End If
wbCurrent.Activate
Dim rOld As Long
Dim rNew As Long
rOld = 0
rNew = 0
Dim index As Long
index = 0
Dim wsOld As Worksheet
Dim wsCurr As Worksheet
Dim LastColumnWrite As Long
Dim WritingRow As Long
Dim LastRowCurrent As Long
Dim LastRowOld As Long
Dim LastColumnCurrent As Long
Dim LastColumnOld As Long
Dim readingrow As Long
For Each wsOld In wbOld.Sheets
On Error Resume Next
Set wsCurr = wbCurrent.Sheets(wsOld.Name)
On Error GoTo 0
If Not wsCurr Is Nothing Then
LastColumnCurrent = GetLasts(wsCurr, "Column") - index
LastRowCurrent = GetLasts(wsCurr, "Row")
LastRowOld = GetLasts(wsOld, "Row")
LastColumnOld = GetLasts(wsOld, "Column")
LastColumnWrite = GetLasts(wsCurr, "Column")
wsOld.Activate
For readingrow = 1 To LastRowOld
With wsOld
On Error Resume Next
Dim AddValue As String
AddValue = Concat(.Range(.Cells(readingrow, 1), .Cells(readingrow, LastColumnCurrent)))
If Not dict.Exists(AddValue) Then
dict.Add key:=AddValue, _
Item:=.Range(.Cells(readingrow, LastColumnCurrent + 1), .Cells(readingrow, LastColumnOld)).Address
End If
On Error GoTo 0
End With
Application.StatusBar = "Reading row " & readingrow & " out of " & LastRowOld
Next readingrow
Application.StatusBar = False
wsCurr.Activate
For WritingRow = 1 To LastRowCurrent
Application.StatusBar = "Writing row in Sheet: " & wsCurr.Name & "=>" & WritingRow & " out of " & LastRowCurrent
ReadingRange = Concat(wsCurr.Range(wsCurr.Cells(WritingRow, 1), wsCurr.Cells(WritingRow, LastColumnCurrent)))
Dim writeRange As Range
If dict.Exists(ReadingRange) = True Then
Set writeRange = wsOld.Range(dict(ReadingRange))
'wsCurr.Range(Cells(WritingRow, LastColumnWrite + 1), Cells(WritingRow, LastColumnOld)) = Split(Dict(ReadingRange), "|")
writeRange.Copy wsCurr.Range(wsCurr.Cells(WritingRow, LastColumnWrite + 1), wsCurr.Cells(WritingRow, LastColumnWrite + 1))
rOld = rOld + 1
Else
Dim outRange As Range
Set outRange = wsCurr.Range(wsCurr.Cells(WritingRow, LastColumnWrite + 1), wsCurr.Cells(WritingRow, LastColumnOld))
Dim cell As Range
outRange.Interior.colorindex = 36
For Each cell In outRange
If cell.Row = 1 Then GoTo nextcell:
If cell.Offset(-1, 0).HasFormula Then
cell.Interior.colorindex = -4142
cell.FillDown
End If
nextcell:
Next cell
'wsCurr.Range(wsCurr.Cells(WritingRow, LastColumnWrite + 1), wsCurr.Cells(WritingRow, LastColumnOld)).Interior.ColorIndex = 36
'wsCurr.Cells(WritingRow, LastColumnWrite + 1) = ReadingRange
rNew = rNew + 1
End If
Next WritingRow
End If
Next wsOld
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
wbOld.Close False
Set wbOld = Nothing
Application.StatusBar = False
MsgBox "There are " & rNew & " new records and " & rOld & " old records!", vbOKOnly, "Success!"
End Sub
Public Function GetLasts(ByVal TargetWorksheet As Worksheet, ByRef RowColum As String) As Long
If Not TargetWorksheet Is Nothing Then
With TargetWorksheet
Select Case True
Case Left$(RowColum, 1) = "R"
On Error Resume Next
GetLasts = .Cells.Find(What:="*", _
after:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
Case Left$(RowColum, 1) = "C"
On Error Resume Next
GetLasts = .Cells.Find(What:="*", _
after:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Select
End With
End If
End Function
Private Function selectedfile(Optional ByVal CurrentFile As String = vbNullString) As String
On Error GoTo ErrorHandler
Dim dialog As FileDialog
Set dialog = Application.FileDialog(msoFileDialogFilePicker)
With dialog
.AllowMultiSelect = False
.InitialFileName = GetSetting("Office1", "CarryForward", "LastPath")
.Title = "Select Old/Previous file for reference: " & CurrentFile
.Show
If .SelectedItems.Count <> 0 Then
selectedfile = .SelectedItems.Item(1)
SaveSetting "Office1", "CarryForward", "LastPath", selectedfile
Workbooks.Open FileName:=selectedfile
selectedfile = Mid$(selectedfile, InStrRev(selectedfile, "") + 1)
End If
End With
If selectedfile = vbNullString Then
MsgBox "You cancelled the prcess!", vbOKOnly, "Alert!"
Exit Function
End If
Exit Function
ErrorHandler:
If Err.Number > 0 Then 'TODO: handle specific error
Err.Clear
Resume Next
End If
End Function
Private Function Concat(ByVal ConcatRange As Range) As String
Dim cell As Variant
Dim delim As String
delim = "|"
Dim Result As String
Result = vbNullString
Dim CellArray As Variant
If ConcatRange.Cells.Count > 1 Then
CellArray = Application.WorksheetFunction.Transpose(ConcatRange.Value)
Else
Concat = ConcatRange.Value
Exit Function
End If
For Each cell In CellArray
If IsError(cell) Then
Dim errstring As String
Dim errval As Variant
errval = cell
Select Case errval
Case CVErr(xlErrDiv0)
errstring = "#DIV"
Case CVErr(xlErrNA)
errstring = "#N/A"
Case CVErr(xlErrName)
errstring = "#NAME"
Case CVErr(xlErrNull)
errstring = "#NULL"
Case CVErr(xlErrNum)
errstring = "#NUM"
Case CVErr(xlErrRef)
errstring = "#REF"
Case CVErr(xlErrValue)
errstring = "#VALUE"
Case Else
errstring = vbNullString
End Select
Result = Result & delim & errstring
Else
Result = Result & delim & cell
End If
Next cell
Concat = Right$(Result, Len(Result) - 1)
End Function
Ниже приведен модуль класса, реализующий объектную ориентацию.
Класс: CarryMe.cls
Option Explicit
Private Type TCell
Book As Workbook
Sheet As Worksheet
LastRow As Long
LastColumn As Long
Records As Long
End Type
Private Previous As TCell
Private Current As TCell
'Add/check Tools> Reference> Microsoft Scripting Runtime
Private dict As Scripting.Dictionary
Public Sub Execute()
'Set screenupdating to false to increase the speed of processing
With Application
'.Calculation = xlCalculationAutomatic
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableCancelKey = xlInterrupt
End With
SelectPreviousFile
If Previous.Book Is Nothing Then Exit Sub
Dim wsheet As Worksheet
For Each wsheet In Current.Book.Sheets
SetParameters wsheet.Name
ReadDataToDictionary
WriteDictToSheet
Next wsheet
Previous.Book.Close False
Set Previous.Book = Nothing
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
MsgBox "There are " & Current.Records & " new records and " & Previous.Records & " old records!", vbOKOnly, "Success!"
End Sub
Private Sub SetParameters(ByVal SheetName As String)
Set Current.Sheet = Current.Book.Sheets(SheetName)
Set Previous.Sheet = Previous.Book.Sheets(SheetName)
With Current.Sheet
Current.LastRow = .Cells.Find(What:="*", after:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
Current.LastColumn = .Cells.Find(What:="*", after:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
End With
If Previous.Sheet Is Nothing Then Exit Sub
With Previous.Sheet
Previous.LastRow = .Cells.Find(What:="*", after:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
Previous.LastColumn = .Cells.Find(What:="*", after:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
End With
End Sub
Private Sub ReadDataToDictionary()
Set dict = New Scripting.Dictionary
With Previous.Sheet
Dim index As Long
For index = 1 To Previous.LastRow
On Error Resume Next
Dim AddValue As String
AddValue = Concat(.Range(.Cells(index, 1), .Cells(index, Current.LastColumn)))
If Not dict.Exists(AddValue) Then
dict.Add key:=AddValue, _
Item:=.Range(.Cells(index, Current.LastColumn + 1), .Cells(index, Previous.LastColumn)).Address
End If
On Error GoTo 0
Next index
End With
End Sub
Private Sub WriteDictToSheet()
With Current.Sheet
Dim index As Long
For index = 1 To Current.LastRow
Application.StatusBar = "Writing row in Sheet: " & Current.Sheet.Name & "=>" & index & " out of " & Current.LastRow
Dim ReadingRange As String
ReadingRange = Concat(.Range(.Cells(index, 1), .Cells(index, Current.LastColumn)))
If dict.Exists(ReadingRange) Then
Dim writeRange As Range
Set writeRange = Previous.Sheet.Range(dict(ReadingRange))
writeRange.Copy .Range(.Cells(index, Current.LastColumn + 1), .Cells(index, Previous.LastColumn + 1))
Previous.Records = Previous.Records + 1
Else
Dim outRange As Range
Set outRange = .Range(.Cells(index, Current.LastColumn + 1), .Cells(index, Previous.LastColumn))
Dim cell As Range
outRange.Interior.colorindex = 36
For Each cell In outRange
If cell.Row = 1 Then GoTo nextcell:
If cell.Offset(-1, 0).HasFormula Then
cell.Interior.colorindex = -4142
cell.FillDown
End If
nextcell:
Next cell
Current.Records = Current.Records + 1
End If
Next index
End With
End Sub
Private Sub SelectPreviousFile()
On Error GoTo ErrorHandler
Dim dialog As FileDialog
Set dialog = Application.FileDialog(msoFileDialogFilePicker)
With dialog
.AllowMultiSelect = False
.InitialFileName = GetSetting("Office1", "CarryForward", "LastPath")
.Title = "Select Old/Previous file for reference: " & Current.Book.Name
.Show
If .SelectedItems.Count <> 0 Then
Dim selectedfile As String
selectedfile = .SelectedItems.Item(1)
SaveSetting "Office1", "CarryForward", "LastPath", selectedfile
Workbooks.Open FileName:=selectedfile
selectedfile = Mid$(selectedfile, InStrRev(selectedfile, "") + 1)
End If
End With
Select Case True
Case selectedfile = vbNullString
MsgBox "You cancelled the prcess!", vbOKOnly, "Alert!"
Case selectedfile = Current.Book.Name
MsgBox "Both file names canot be same! System cannot distinguish between old and new file.", vbCritical, "Rename Either of the File"
Case Else
Set Previous.Book = Workbooks(selectedfile)
End Select
Exit Sub
ErrorHandler:
If Err.Number > 0 Then 'TODO: handle specific error
Err.Clear
Resume Next
End If
End Sub
Private Function Concat(ByVal ConcatRange As Range) As String
Dim cell As Variant
Dim delim As String
delim = "|"
Dim Result As String
Result = vbNullString
Dim CellArray As Variant
If ConcatRange.Cells.Count > 1 Then
CellArray = Application.WorksheetFunction.Transpose(ConcatRange.Value)
Else
Concat = ConcatRange.Value
Exit Function
End If
For Each cell In CellArray
If IsError(cell) Then
Dim errstring As String
Dim errval As Variant
errval = cell
Select Case errval
Case CVErr(xlErrDiv0)
errstring = "#DIV"
Case CVErr(xlErrNA)
errstring = "#N/A"
Case CVErr(xlErrName)
errstring = "#NAME"
Case CVErr(xlErrNull)
errstring = "#NULL"
Case CVErr(xlErrNum)
errstring = "#NUM"
Case CVErr(xlErrRef)
errstring = "#REF"
Case CVErr(xlErrValue)
errstring = "#VALUE"
Case Else
errstring = vbNullString
End Select
Result = Result & delim & errstring
Else
Result = Result & delim & cell
End If
Next cell
Concat = Right$(Result, Len(Result) - 1)
End Function
Private Sub Class_Initialize()
Set Current.Book = ActiveWorkbook
Set Previous.Sheet = Nothing
Set Current.Sheet = Nothing
End Sub
Использование: следуя коду, который я использую для запуска класса и использования макроса.
Модуль: TempModule.bas
Public Sub TestingCarryClass()
Dim CarryForward As CarryMe
Set CarryForward = New CarryMe
CarryForward.Execute
End Sub
1 ответ
Версия кода ООП породила некоторые мысли о разделении задач: взаимодействие с пользователем и обработка данных.
Принцип единственной ответственности (СЕРП):
Каждый модуль, класс или функция в компьютерной программе должен нести ответственность за отдельную часть функциональности этой программы, и он должен инкапсулировать эту часть.
SRP будет способствовать определению взаимодействия с пользователем и обработки данных как двух обязанностей.
Итак, учитывая версию ООП CarryForwardOld
, есть два модуля:
TempModule
а также CarryMe
.
TempModule
явно делает один thing
:
Это точка входа в выполняемую операцию. Как только точка входа вызывается, она делегирует всю работу Class Module.CarryMe
для обработки.
CarryMe
тем не менее, делает нечто большее:
- Запрашивает взаимодействие с пользователем, чтобы выбрать «Предыдущий» файл и подтвердить успех процесса.
- Изменяет «текущую» книгу на основе данных в «предыдущей» книге для переноса данных.
Итак, разумное улучшение CarryMe
class будет позволять тестировать его без человеческого взаимодействия. В настоящее время пользователь должен выбрать исходную книгу. Также в конце звонка Execute
, пользователь получает всплывающее сообщение, требующее подтверждения. Любое из этих действий пользователя исключает возможность использования тестового клиента только для кода.
CarryMe
требуется два объекта Workbook (предыдущий и текущий) для работы. Однако нет причин, по которымCarryMe
класс должен взять на себя ответственность за получающий рабочие тетради. Далее, для выполнения своей задачи CarryMe
класс не должен нести ответственность за индикацию успеха с помощью всплывающего сообщения. Путем извлечения кода взаимодействия с пользователем из CarryMe
, CarryMe.Execute
может быть протестирован.
Таким образом, вместо того, чтобы раскрывать подпрограмму без параметров (CarryMe.Execute
), чтобы выполнить задачу, можно было бы предоставить функцию, которая принимает два Workbook
параметры и возвраты True
в случае успеха (и False
если не получится).
Используя Boolean
функция возврата — это типичный шаблон, который обеспечивает «безопасный» способ попытаться выполнить операцию, которая может потерпеть неудачу. Шаблон / функция гарантирует, что он вернет результат «прошел / не прошел», а не вызовет исключение или вернет код ошибки. Функции обычно предваряются Try
и может либо попытаться выполнить операцию, либо попытаться получить значение / объект. В любом случае шаблон TryXXXX избавляет вызывающий код от необходимости перехватывать исключение или оценивать коды возврата ошибок.
Ниже Execute
подпрограмма была изменена на Boolean
функция возврата TryExecute
:
Public Function TryExecute(ByVal currentWrkbk As Workbook, ByVal previousWrkbk As Workbook) As Boolean
'TryExecute wraps the operation with error handling to guarantee Excel
'Application settings are reset.
'Note: The original Execute() version has a bug in that these settings are not reset if a
'Previous' workbook is not selected by the user.
If previousWrkbk Is Nothing Then Exit Function
TryExecute = False 'will be set to True if the code succeeds
On Error GoTo ErrorExit:
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableCancelKey = xlInterrupt
End With
Set Current.Book = currentWorkbook
Set Previous.Book = previousWrkbk
Dim wsheet As Worksheet
For Each wsheet In Current.Book.Sheets
SetParameters wsheet.Name
ReadDataToDictionary
WriteDictToSheet
Next wsheet
TryExecute = True
ErrorExit:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Function
Для автоматизированного тестирования (без взаимодействия с пользователем) тестовый модуль может тестировать TryExecute
с кодом вроде:
Public Function CarryForwardTryExecuteTest() As Boolean
Dim previousWorkbook as Workbook
Dim previousWorkbookPath As String
previousWorkbookPath = <Filepath to a test 'previous' workbook>
Set previousWorkbook = Workbooks.Open(previousWorkbookPath)
Dim currentWorkbook as Workbook
Dim currentWorkbookPath As String
currentWorkbookPath = <Filepath to a test 'current' workbook>
Set currentWorkbook = Workbooks.Open(currentWorkbookPath )
Dim CarryForward As CarryMe
Set CarryForward = New CarryMe
CarryForwardTryExecuteTest= CarryForward.TryExecute(currentWorkbook, previousWorkbook) Then
End Function
Итак, где следует обрабатывать извлеченные взаимодействия с пользователем? Модуль TempModule
, который вызывается пользователем, является кандидатом на обработку взаимодействий с пользователем. Если можно предположить, что TempModule.TestingCarryClass
может быть вызван только пользователем, тогда разумно поддерживать взаимодействие с пользователем из TempModule
. В противном случае добавьте еще один модуль и EntryPoint, которые будут отвечать за процессы, инициированные пользователем.
Так что если TempModule
обрабатывает взаимодействия с пользователем, это будет выглядеть так:
Option Explicit
Public Sub TestingCarryClass()
Dim previousWorkbook As Workbook
Set previousWorkbook = SelectPreviousFile()
If previousWorkbook Is Nothing Then
Exit Sub
End If
Dim CarryForward As CarryMe
Set CarryForward = New CarryMe
'Note the addition of Properties CurrentRecordCount and PreviousRecordCount
'to CarryMe
If CarryForward.TryExecute(Application.ActiveWorkbook, previousWorkbook) Then
MsgBox "There are " & CarryForward.CurrentRecordCount & " new records and " & CarryForward.PreviousRecordCount & " old records!", vbOKOnly, "Success!"
Exit Sub
End If
MsgBox "Unexpected Error"
End Sub
'Note: unchanged
Private Function SelectPreviousFile() As Workbook
Set SelectPreviousFile = Nothing
On Error GoTo ErrorHandler
Dim dialog As FileDialog
Set dialog = Application.FileDialog(msoFileDialogFilePicker)
With dialog
.AllowMultiSelect = False
.InitialFileName = GetSetting("Office1", "CarryForward", "LastPath")
.Title = "Select Old/Previous file for reference: " & Current.Book.Name
.Show
If .SelectedItems.Count <> 0 Then
Dim selectedfile As String
selectedfile = .SelectedItems.Item(1)
SaveSetting "Office1", "CarryForward", "LastPath", selectedfile
Workbooks.Open Filename:=selectedfile
selectedfile = Mid$(selectedfile, InStrRev(selectedfile, "") + 1)
End If
End With
Select Case True
Case selectedfile = vbNullString
MsgBox "You cancelled the prcess!", vbOKOnly, "Alert!"
Case selectedfile = ActiveWorkbook.Name 'Current.Book.Name
MsgBox "Both file names canot be same! System cannot distinguish between old and new file.", vbCritical, "Rename Either of the File"
Case Else
'Set Previous.Book = Workbooks(selectedfile)
Set SelectPreviousFile = Workbooks(selectedfile)
End Select
Exit Function
ErrorHandler:
If Err.Number > 0 Then 'TODO: handle specific error
Err.Clear
Resume Next
End If
End Function
Извлечение ответственности за пользовательский интерфейс из CarryMe
class позволяет ему сосредоточиться на обработке книги (единственная ответственность) с обязанностями пользовательского интерфейса, обрабатываемыми TempModule
. А также…CarryMe.TryExecute
теперь можно провести модульное тестирование.
Большое спасибо за вводные данные, я начал реализовывать это, используя шаблон команды из Rubberduckvba (Rubberduckvba.wordpress.com/2020/11/19/…), но не понимал, что для целей тестирования я должен отделить взаимодействие с пользователем от других функций. Быстрый вопрос: в классе должна быть только функция, доступная клиентскому коду, верно? который принимает 2 книги и возвращает логическое значение. Я думаю, что пропустил тестовую часть, и мне нужно работать над тем, чтобы сделать свои коды более удобными для тестирования. Еще раз спасибо за мысли.
— Випул Каркар