2
\$\begingroup\$

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
\$\endgroup\$
8
  • \$\begingroup\$ Do you have a link to the original code or something similar? What do the ellipses represent? Is there a sample of a "classFix1" that you can share? \$\endgroup\$ – Comintern Feb 25 '19 at 21:30
  • \$\begingroup\$ @Comintern I'm happy to help however I can. The ellipses represent the same pattern continued through several dozen fixes. I'm happy to expand on the above however you'd like though I don't have a link directly to the original code just because this is for work so I need to be abstract - just let me know what you'd like to see and I'll get you an abstraction. Posting a sample class now per your request. \$\endgroup\$ – puzzlepiece87 Feb 25 '19 at 21:33
  • \$\begingroup\$ Excuse me, not an abstraction unless it just repeats something 3 dozen times - I meant an anonymized form. \$\endgroup\$ – puzzlepiece87 Feb 25 '19 at 21:45
  • \$\begingroup\$ Are the other "fixes" similar to that one? I.e., one method that actually performs the fix and maybe a handful of utilities? \$\endgroup\$ – Comintern Feb 25 '19 at 21:46
  • 1
    \$\begingroup\$ It's possible I'll suggest a really deep redesign... ;-) \$\endgroup\$ – Comintern Feb 25 '19 at 22:01

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.