This is another review on a program I've asked about before, with a different target in mind.
Program Function
As before, this program makes emergency changes to medical claim files, delivers all the corrected files analysts need, and produces a changelog as well for their review.
Core Problem - tl;dr Use of dictionary containing dozens of different classes is neutering important IDE tools
Each medical file fix I develop gets its own class. Originally, every class was initialized and used in the core procedure FixTextFiles.
As the number of fixes expanded into the dozens, this became bothersome. 3/4 of my core procedure (by lines of code) was taken up by initializing dozens of classes, most of which would not even be used that run.
I solved this issue by making an ActiveFixes class with a dictFixClassesByFixName dictionary that took care of class initialization and trimmed things down to the classes that would actually be used that run.
I refer to this dictionary constantly throughout my code, but this design prevents me from using the VBEditor's compilation and Rubberduck VBA's code analysis tools to spot easy errors, like missing arguments for methods of the classes in the dictionary, before running the actual program. It's making testing way harder than it needs to be.
Main Question
How would you redesign this part of the program knowing:
- There's dozens of fixes, each with its own class, unique methods, etc.
- No more than 1-4 will be active at a time (user-selected)
- I want the IDE's tools to be able function well enough to throw compile errors if I misspell a method name or if I'm missing arguments
classActiveFixes - class names changed to protect the innocent
Option Explicit
Private pdictFixClassesByFixName As Scripting.Dictionary
'pdictFixClassesByFixName Properties
Public Property Get dictFixClassesByFixName() As Scripting.Dictionary
Set dictFixClassesByFixName = pdictFixClassesByFixName
End Property
Public Property Set dictFixClassesByFixName(ByVal dictFixClassesByFixName As Scripting.Dictionary)
Set pdictFixClassesByFixName = dictFixClassesByFixName
End Property
Public Sub Setup(ByVal ActiveFixes As classActiveFixes)
Dim dictAllFixClassesByFixName As Scripting.Dictionary
Set dictAllFixClassesByFixName = GetAllFixesDictionary
dictAllFixClassesByFixName.CompareMode = TextCompare
Set ActiveFixes.dictFixClassesByFixName = New Scripting.Dictionary
ActiveFixes.dictFixClassesByFixName.CompareMode = TextCompare
With SelectFixes
Dim rngSelectFixesTable As Range
Set rngSelectFixesTable = .Range(.Cells(5, 1), .Cells(GetLastRowOfSheetInColumn(SelectFixes, 1), 1))
End With
Dim rngFix As Range
For Each rngFix In rngSelectFixesTable
If SelectFixes.Shapes("ToggleBackground" & rngFix.Row - 4).TextFrame.Characters.Text = "On" Then
If ActiveFixes.dictFixClassesByFixName.Exists(rngFix.Value) = False Then
ActiveFixes.dictFixClassesByFixName.Add rngFix.Value, dictAllFixClassesByFixName.Item(rngFix.Value)
If rngFix.Offset(0, 2).Value <> vbNullString Then
Set ActiveFixes.dictFixClassesByFixName.Item(rngFix.Value).shtSettings = ThisWorkbook.Worksheets(rngFix.Offset(0, 2).Value)
End If
End If
End If
Next rngFix
ActiveFixes.dictFixClassesByFixName.Add "Special Always On Fix", dictAllFixClassesByFixName.Item("Special Always On Fix")
PerFixSetup ActiveFixes
End Sub
Private Function GetAllFixesDictionary() As Scripting.Dictionary
Dim dictAllFixes As Scripting.Dictionary
Set dictAllFixes = New Scripting.Dictionary
dictAllFixes.CompareMode = TextCompare
Dim Fix1 As classFix1
Set Fix1 = New classFix1
dictAllFixes.Add "Fix1", Fix1
Dim Fix2 As classFix2
Set Fix2 = New classFix2
dictAllFixes.Add "Fix2", Fix2
...
Dim FixN As classFixN
Set FixN = New classFixN
dictAllFixes.Add "FixN", FixN
Dim FixSpecialAlwaysOn As classFixSpecialAlwaysOn
Set FixSpecialAlwaysOn = New classFixSpecialAlwaysOn
dictAllFixes.Add "Special Always On Fix", FixSpecialAlwaysOn
Set GetAllFixesDictionary = dictAllFixes
End Function
Private Function GetLastRowOfSheetInColumn(ByVal shtInQuestion As Worksheet, ByVal lngColumnInQuestion As Long) As Long
With shtInQuestion
'Using the end up method on a full sheet will go to the top
If .Cells(.Rows.Count, lngColumnInQuestion).Value <> vbNullString Then
GetLastRowOfSheetInColumn = .Rows.Count
Else
GetLastRowOfSheetInColumn = .Cells(.Rows.Count, lngColumnInQuestion).End(xlUp).Row
End If
End With
End Function
Private Sub PerFixSetup(ByVal ActiveFixes As classActiveFixes)
'Not every class has a setup method
If ActiveFixes.dictFixClassesByFixName.Exists("Fix3") = True Then
ActiveFixes.dictFixClassesByFixName("Fix3").Setup ActiveFixes.dictFixClassesByFixName("Fix3")
End If
If ActiveFixes.dictFixClassesByFixName.Exists("Fix5") = True Then
ActiveFixes.dictFixClassesByFixName("Fix5").Setup ActiveFixes.dictFixClassesByFixName("Fix5")
End If
...
If ActiveFixes.dictFixClassesByFixName.Exists("FixN-3") = True Then
ActiveFixes.dictFixClassesByFixName("FixN-3").Setup ActiveFixes.dictFixClassesByFixName("FixN-3")
End If
End Sub
M0FixTextFiles
Public Sub FixTextFiles(Optional ByVal folderSourceFiles As Scripting.Folder = Nothing, Optional ByVal strFixName As String = vbNullString, Optional ByVal strNewLineDelimiter As String = vbNullString, Optional ByVal strNewClaimDelimiter As String = vbNullString, Optional ByVal folderDestination As Scripting.Folder = Nothing)
'
' Keyboard Shortcut: Ctrl+Shift+Q
Dim strLines() As String 'The original file as an array where each line is an array item
Dim strLines2() As String 'The revised file as an array where each line is an array item
Dim lngCurrentLineNumber As Long
Dim strCurrentLine As String
If OkayToDeleteOldResults(folderSourceFiles Is Nothing) = False Then Exit Sub
If Not (folderSourceFiles Is Nothing) Then
TurnOffAllFixesExceptParameterFix strFixName
GetCellWithValueInRange(InstructionsAndOptions.Columns(11), "New Line Delimiter:", True).Offset(0, 1).Value = strNewLineDelimiter
GetCellWithValueInRange(InstructionsAndOptions.Columns(11), "New Claim Delimiter:", True).Offset(0, 1).Value = strNewClaimDelimiter
GetCellWithValueInRange(InstructionsAndOptions.Columns(11), "Create Changelog Sheets:", True).Offset(0, 1).Value = "No"
End If
Dim ActiveFixes As classActiveFixes
Set ActiveFixes = New classActiveFixes
ActiveFixes.Setup ActiveFixes
If ActiveFixes.dictFixClassesByFixName.Count = 0 Then
MsgBox "No fixes active."
Exit Sub
End If
'--- Preparation ---
'Speed Enhancers
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim Model As classModel
Set Model = New classModel
Model.Setup
'-- Select Files --
Dim varFiles As Variant
If folderSourceFiles Is Nothing Then
MsgBox "Select all of your files (use Ctrl-A in the folder or Ctrl-left mouse button)."
Dim dialogFilePicker As FileDialog
Set dialogFilePicker = Application.FileDialog(msoFileDialogFilePicker)
With dialogFilePicker
.AllowMultiSelect = True
.Title = "Select files to fix"
If .Show = False Then CancelFixTextFiles
End With
Set varFiles = dialogFilePicker.SelectedItems
Else
Set varFiles = folderSourceFiles.Files
End If
Dim varFile As Variant
For Each varFile In varFiles
Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject
Dim fileCurrent As Scripting.File
Set fileCurrent = FSO.GetFile(varFile)
'--- Parse File ---
Dim strEntireFile As String
strEntireFile = SaveFileToString(fileCurrent)
If strEntireFile <> vbNullString Then
'File not delimited properly
If InStr(1, strEntireFile, Model.strNewLineDelimiter, vbTextCompare) > 0 Then
'Eliminate blank line(s) at end of file, if any, for easier parsing
Do Until Right(strEntireFile, 1) <> Model.strNewLineDelimiter
strEntireFile = Left(strEntireFile, Len(strEntireFile) - 1)
Loop
strLines() = Split(strEntireFile, Model.strNewLineDelimiter)
strLines2() = Split(strEntireFile, Model.strNewLineDelimiter)
'--- Begin File Manipulation ---
For lngCurrentLineNumber = LBound(strLines) To UBound(strLines) 'For some reason is 1-based
'Progress Tracker
Application.StatusBar = lngCurrentLineNumber & " / " & UBound(strLines)
If Right(lngCurrentLineNumber, 3) = "000" Then DoEvents
'--- Ongoing variables ---
'Current line
strCurrentLine = strLines(lngCurrentLineNumber)
'Segment type
Dim strSegmentType As String
If InStr(1, strCurrentLine, "*", vbTextCompare) = 0 Then
strSegmentType = vbNullString
Else
strSegmentType = Left(strCurrentLine, InStr(1, strCurrentLine, "*", vbTextCompare) - 1)
End If
'--- Fixes ---
'Note: the weird structures below occur because VBA doesn't support short-circuit evaluation
If ActiveFixes.dictFixClassesByFixName.Exists("Fix1") = True Then
If strSegmentType = "A" Then
strLines2(lngCurrentLineNumber) = ActiveFixes.dictFixClassesByFixName("Fix1").Fix1Method1(strCurrentLine, lngHLCount, lngLastHLBilling)
End If
End If
...
'Special Always On Fix
If strSegmentType = "B" Then ActiveFixes.dictFixClassesByFixName("Special Always On Fix").FixSpecialAlwaysOnProperty1 = ActiveFixes.dictFixClassesByFixName("Special Always On Fix").GetProperty1Value(strCurrentLine)
End If
Next lngCurrentLineNumber
If Model.boolCreateChangelogSheets = True Then WriteOriginalAndUpdatedSegmentsToWorksheetAndHighlightDifferences strLines, strLines2, fileCurrent
WriteUpdatedSegmentsToNewFile strLines2, Model.strNewLineDelimiter, fileCurrent, folderDestination
Else
Dim strTempDelimiter As String
strTempDelimiter = Model.strNewLineDelimiter
If strTempDelimiter = vbCrLf Then strTempDelimiter = "vbCrLf"
If strTempDelimiter = vbCr Then strTempDelimiter = "vbCr"
If strTempDelimiter = vbLf Then strTempDelimiter = "vbLf"
MsgBox fileCurrent.Name & " was skipped because it is not delimited with " & strTempDelimiter & ". Either wrap the file in this character or change the setting on the " & InstructionsAndOptions.Name & " sheet."
End If
End If
Next varFile
'-- All Done --
If folderSourceFiles Is Nothing Then MsgBox "All files have been fixed and saved to the same folders as the source files with " & """" & "Fixed" & """" & " added to their filenames. No original files have been modified."
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
classFix3 - Sample posted per @Comintern's request
Option Explicit
Private pshtSettings As Worksheet
Private pdictReplacementCrosswalk As Scripting.Dictionary
'pshtSettings Properties
Public Property Get shtSettings() As Worksheet
Set shtSettings = pshtSettings
End Property
Public Property Set shtSettings(ByVal shtSettings As Worksheet)
Set pshtSettings = shtSettings
End Property
'pdictReplacementCrosswalk Properties
Public Property Get dictReplacementCrosswalk() As Scripting.Dictionary
Set dictReplacementCrosswalk = pdictReplacementCrosswalk
End Property
Private Property Set dictReplacementCrosswalk(ByVal dictReplacementCrosswalk As Scripting.Dictionary)
Set pdictReplacementCrosswalk = dictReplacementCrosswalk
End Property
Public Sub Setup(ByVal Fix3 As classFix3)
With Fix3.shtSettings
'Dictionary initialization
Set dictReplacementCrosswalk = New Scripting.Dictionary
dictReplacementCrosswalk.CompareMode = vbTextCompare
Dim lngNumberOfClaims As Long
lngNumberOfClaims = WorksheetFunction.CountA(.Columns(1))
'Warning if settings sheet empty
If lngNumberOfClaims < 2 Then 'There are headers on this sheet
MsgBox "Fix 3 option is ON, but a crosswalk cannot be detected when searching Column 1 of the " & Fix3.shtSettings.Name & " sheet."
CancelFixTextFiles
Else
Dim arrSubstitutions As Variant
Set arrSubstitutions = ConvertRangeToArray(.Range(.Cells(2, 1), .Cells(lngNumberOfClaims, 16)))
End If
'Populate dictionary from info
Dim lngIndex As Long
For lngIndex = LBound(arrSegmentSubstitutions, 1) To UBound(arrSegmentSubstitutions, 1)
dictSegmentReplacementCrosswalk.Add Key:=arrSegmentSubstitutions(lngIndex, 1), Item:=arrSegmentSubstitutions(lngIndex, 2)
Next lngIndex
End With
End Sub
Public Function FixLine(ByVal strCurrentLine As String) As String
Dim strFixedLine As String
strFixedLine = strCurrentLine
'XXXXX
If Left(strCurrentLine, 5) = "XXXXX" Then
If Right(strCurrentLine, 2) = "YY" Then
strFixedLine = Left(strFixedLine, Len(strFixedLine) - 2) & "16"
Else
MsgBox "XXXXX segment that doesn't end with YY found"
End If
End If
'Crosswalk replacement
If Left(strCurrentLine, 7) = "XXXXXXX" Then strFixedLine = dictReplacementCrosswalk.Item(strCurrentLine)
FixLine = strFixedLine
End Function
Private Function ConvertRangeToArray(ByVal rngInQuestion As Range) As Variant
Dim arrRangeToArray() As Variant
With rngInQuestion
If .Cells.Count = 1 Then
ReDim arrRangeToArray(1 To 1, 1 To 1)
arrRangeToArray(1, 1) = .Cells(1, 1).Value
Else
arrRangeToArray = .Value
End If
End With
ConvertRangeToArray = arrRangeToArray
End Function
