7
\$\begingroup\$

I am trying to perfect my string splitter's performance, to be more fast, more easy to maintain if someone else reads it and more readable code-wise.

Context ,Scope and Objectives

Where I work we use a sort of "configuration files" to calculate some data warehouse databases.

For example, if you wanted to config a file to calculate the number of supermarkets in a country, the config file would like the below example, where the: first line is the description/name of the store and the line below is the code for the program to pick up (where 50 = S is the category for the sales, 97 = 01 is the "I've bought it myself" and 183 is the column where the code for the store is stored (in this case 0040).

Store1
50=S+97=01+183=0040

So the codes for the configuration are mostly the same across all variables, but it always end with an equal sign. It happens that when a store has more than 10 codes we have to split them manually, it results in a quite of work.

My ultimate goal for this string splitter is for it to be : fast, reliable, easy to maintain /understand and user friendly.

Concerns about code

Being unexperienced with programming, I still have issues using the proper naming conventions. I have been studying the VBA Developers Handbook by Ken Getz and I didn't quite understand the conventions.

Also I feel that I am using a shotgun to kill a ant (apologies for the cringy metaphor).

Code & Logic

  • I've started with a main object where I store the general procedures to make/call:

    Option Explicit
    
    Private Sub SplitCodes()
    
        Dim inputRange As Range
        Dim currentSheetIndex As Long
    
        currentSheetIndex = ActiveSheet.Index
        Set inputRange = Application.InputBox("Select single cell.", "Selection", Type:=8)
    
        ExcelOptimization (True)
    
        If ValidateData(inputRange, currentSheetIndex) = True Then
            If RunSplitter(inputRange, currentSheetIndex) = True Then
                If RemoveCommas(inputRange, currentSheetIndex) = True Then
                    MsgBox "Splitter run sucessfully", vbOKOnly, "Splitter"
                Else
                    MsgBox "Critical error ocurred. Please contact admin", vbCritical, "Critical"
                End If
            End If
        End If
        ExcelOptimization (False)
    
    End Sub 
    

  • Then I created an procedure to optimize simple excel stuff like the ScreenUpdating:

    Private Sub ExcelOptimization(ByVal turnState As Boolean)
    
        If turnState = False Then
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
            Application.EnableEvents = True
        Else
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            Application.EnableEvents = False
        End If
    
    End Sub 
    

  • Then I've managed to write a validation procedure to check whether the list is missing a code/description, by checking if the rows are pair, and to check if the second item has a code like value (50=S+97=01+183=XXXX):

    Private Function ValidateData(ByVal inputRange As Variant, ByVal activeSheetIndex As Long) As Boolean
    
        Dim errorMessage As String, stringToFind As String
        Dim countRows As Long, countArray As Long
        Dim stringPosition As Long, stringCharacterCount As Long
        Dim delimiterArray() As String
    
        On Error GoTo ErrorHandler
    
            countRows = Sheets(activeSheetIndex).Range(inputRange, inputRange.End(xlDown)).Rows.Count
            stringToFind = "=|#"
            delimiterArray = Split(stringToFind, "|")
    
            If countRows Mod 2 = 0 Then
    
                If Len(inputRange) > 0 Then
    
                    For countArray = LBound(delimiterArray) To UBound(delimiterArray)
                        stringPosition = 1
                        stringToFind = delimiterArray(countArray)
                        Do
                            stringPosition = InStr(stringPosition, inputRange, stringToFind, vbBinaryCompare)
                            If stringPosition > 0 Then
                                stringCharacterCount = stringCharacterCount + 1
                                stringPosition = stringPosition + Len(stringToFind)
                            End If
                        Loop While stringPosition > 0
                    Next countArray
    
                        If stringCharacterCount > 0 Then
                            MsgBox "Error, the range cannot start with a code", vbCritical
                            ValidateData = False
                            Exit Function
                        Else
                            ValidateData = True
                        End If
                End If
    
            Else
                MsgBox "Range is uneven. Please recheck.", vbCritical, "Error found!"
                Exit Function
            End If
    
    ErrorHandler:
    
        If Err.Number <> 0 Then
    
            errorMessage = "Error #" & Str$(Err.Number) & " was generated by " & Err.Source & "." & Chr$(10) & "Error description: " & Err.Description
            MsgBox errorMessage, , "Error", Err.HelpFile, Err.HelpContext
            Exit Function
        End If
    
    End Function 
    

  • This is the function that does most of the work, where it splits everything with > 8 links/codes:

    Private Function RunSplitter(ByVal inputRange As Variant, ByVal activeSheetIndex As Long) As Boolean
    
    
        Dim errorMessage As String, stringToFind As String, codeString As String, arrayString As String, codeBuilderString As String
        Dim countRows As Long, countArray As Long, counterCodeArray As Long, counterRow As Long
        Dim stringPosition As Long, stringCharacterCount As Long, stringLastPosition As Long
        Dim delimiterArray() As String, codeArray() As String
        Dim isUBound As Boolean, isEndOfArray As Boolean
    
        On Error GoTo ErrorHandler
        RunSplitter = False
        codeBuilderString = CodeStringBuilder(inputRange)
        countRows = Sheets(activeSheetIndex).Range(inputRange, inputRange.End(xlDown)).Rows.Count
        stringToFind = "=|#"
        delimiterArray = Split(stringToFind, "|")
        isUBound = False
        isEndOfArray = False
    
         For counterRow = inputRange.Row To countRows
            If Len(ActiveSheet.Cells(counterRow, inputRange.Column)) > 0 Then
                For countArray = LBound(delimiterArray) To UBound(delimiterArray)
                    stringLastPosition = 0
                    stringPosition = 1
                    stringToFind = delimiterArray(countArray)
    
                    Do
                        stringPosition = InStr(stringPosition, ActiveSheet.Cells(counterRow, inputRange.Column), stringToFind, vbBinaryCompare)
                        If stringPosition > 0 Then
                            stringCharacterCount = stringCharacterCount + 1
                            stringPosition = stringPosition + Len(stringToFind)
                            stringLastPosition = stringPosition
                        End If
                    Loop While stringPosition > 0
    
                    If stringLastPosition > 0 Then
                        codeString = Mid$(ActiveSheet.Cells(counterRow, inputRange.Column), stringLastPosition, Len(ActiveSheet.Cells(counterRow, inputRange.Column)))
                        codeArray = Split(codeString, ",")
    
                        If UBound(codeArray) > 9 Then
                            arrayString = vbNullString
    
                            For counterCodeArray = LBound(codeArray) To UBound(codeArray)
                                isUBound = (counterCodeArray = UBound(codeArray))
    
                                If counterCodeArray > 8 Then
                                    If (counterCodeArray Mod 9 = 0) Then
                                        isEndOfArray = True
                                        arrayString = vbNullString
                                        ActiveSheet.Cells(counterRow + 1, inputRange.Column).Insert
                                        ActiveSheet.Cells(counterRow + 2, inputRange.Column).Insert
                                        ActiveSheet.Cells(counterRow + 1, inputRange.Column).NumberFormat = "@"
                                        ActiveSheet.Cells(counterRow + 2, inputRange.Column).NumberFormat = "@"
                                        ActiveSheet.Cells(counterRow + 1, inputRange.Column).Value = ActiveSheet.Cells(counterRow - 1, inputRange.Column).Value
                                        arrayString = arrayString + codeArray(counterCodeArray) + ","
                                        ActiveSheet.Cells(counterRow + 2, inputRange.Column).Value = codeBuilderString + arrayString
    
                                        If isUBound = True Then
                                            arrayString = arrayString + codeArray(counterCodeArray)
                                        End If
    
                                    Else
                                        If isEndOfArray = True Then
                                            arrayString = arrayString + codeArray(counterCodeArray) + ","
                                            ActiveSheet.Cells(counterRow + 2, inputRange.Column).Value = codeBuilderString + arrayString
                                        Else
                                            arrayString = arrayString + codeArray(counterCodeArray) + ","
                                            ActiveSheet.Cells(counterRow, inputRange.Column).Value = codeBuilderString + arrayString
                                        End If
                                    End If
    
                                Else
                                    arrayString = arrayString + codeArray(counterCodeArray) + ","
                                    ActiveSheet.Cells(counterRow, inputRange.Column).Value = codeBuilderString + arrayString
                                End If
    
                            Next counterCodeArray
                        End If
                    End If
                isUBound = False
                isEndOfArray = False
                Next countArray
            End If
    
        Next counterRow
        RunSplitter = True
    
    ErrorHandler:
    
        If Err.Number <> 0 Then
            errorMessage = "Error #" & Str$(Err.Number) & " was generated by " & Err.Source & "." & Chr$(10) & "Error description: " & Err.Description
            MsgBox errorMessage, , "Error", Err.HelpFile, Err.HelpContext
            Exit Function
        End If
    
    End Function 
    

  • The way the code is setup, when it splits it creates a comma at the end of split, so this removes them:

    Private Function RemoveCommas(ByVal inputRange As Variant, ByVal activeSheetIndex As Long) As Boolean
    
        Dim errorMessage As String
        Dim countRows As Long, counterRow As Long, lengthString As Long
    
        On Error GoTo ErrorHandler
        countRows = Sheets(activeSheetIndex).Range(inputRange, inputRange.End(xlDown)).Rows.Count
    
        For counterRow = inputRange.Row To countRows
            If Right$(ActiveSheet.Cells(counterRow, inputRange.Column).Value, 1) = "," Then
                lengthString = Len(ActiveSheet.Cells(counterRow, inputRange.Column))
                ActiveSheet.Cells(counterRow, inputRange.Column).NumberFormat = "@"
                ActiveSheet.Cells(counterRow, inputRange.Column).Value = Left$(ActiveSheet.Cells(counterRow, inputRange.Column), lengthString - 1)
            End If
        Next counterRow
    
        RemoveCommas = True
    
    ErrorHandler:
    
        If Err.Number <> 0 Then
    
            errorMessage = "Error #" & Str$(Err.Number) & " was generated by " & Err.Source & "." & Chr$(10) & "Error description: " & Err.Description
            MsgBox errorMessage, , "Error", Err.HelpFile, Err.HelpContext
            Exit Function
        End If
    
    End Function 
    

  • This function creates the "50=S+97...." part and addes it to the codes:

    Private Function CodeStringBuilder(ByVal inputRange As Variant) As String
    
        Dim errorMessage As String, codeString As String
        Dim lengthString As Long, stringPosition As Long, stringLastPosition As Long
    
        On Error GoTo ErrorHandler
        stringPosition = 1
        stringLastPosition = 0
    
        Do
            stringPosition = InStr(stringPosition, ActiveSheet.Cells(inputRange.Row + 1, inputRange.Column), "=", vbBinaryCompare)
    
            If stringPosition > 0 Then
                stringPosition = stringPosition + 1
                stringLastPosition = stringPosition
            End If
    
        Loop While stringPosition > 0
    
        lengthString = Len(ActiveSheet.Cells(inputRange.Row + 1, inputRange.Column)) - stringLastPosition + 1
        lengthString = Len(ActiveSheet.Cells(inputRange.Row + 1, inputRange.Column)) - lengthString
        codeString = Left$(ActiveSheet.Cells(inputRange.Row + 1, inputRange.Column), lengthString)
    
        CodeStringBuilder = codeString
    
    ErrorHandler:
    
        If Err.Number <> 0 Then
    
            errorMessage = "Error #" & Str$(Err.Number) & " was generated by " & Err.Source & "." & Chr$(10) & "Error description: " & Err.Description
            MsgBox errorMessage, , "Error", Err.HelpFile, Err.HelpContext
            Exit Function
        End If
    
    End Function 
    

I've added a test set of data to use and the results I get. It can be found at this pastebin link

Important note: I've run the rubber duck on this version and updated the code! Also, thanks for reviewing a very long code post!

\$\endgroup\$
5
  • 2
    \$\begingroup\$ Rubberduck 2.0.11 inspections will pop results for multiple declarations in the same instruction at several places, unqualified Sheets and Cells calls implicitly referring to the active worksheet, use of variant-returning string functions instead of the string-returning equivalents (e.g. Right instead of Right$); v2.0.12 (not released yet) is also going to complain about some Hungarian Notation with a few identifier names (e.g. intRow), and ..I haven't run it either, so there might be some unused locals too. Kudos for mentioning Rubberduck! Why not run inspections before CR? \$\endgroup\$ Jan 16, 2017 at 16:42
  • 3
    \$\begingroup\$ Note: Running RD is not required for a post on CR. However, it certainly will help you fix some issues so we don't have to comment on them. \$\endgroup\$
    – user34073
    Jan 16, 2017 at 16:43
  • 1
    \$\begingroup\$ The fourth bullet point - does the function have a name? Or input? What does it return? I assume it's Function RunSplitter() As Boolean but does it have arguments? \$\endgroup\$ Jan 20, 2017 at 16:48
  • 1
    \$\begingroup\$ Maybe it's Function RunSplitter(ByVal inputrange As Range, ByVal activesheetindex As Long) As Boolean? \$\endgroup\$ Jan 20, 2017 at 16:54
  • \$\begingroup\$ @Raystafarian sorry it was a edit issue! should look better now \$\endgroup\$
    – svacx
    Jan 20, 2017 at 17:09

1 Answer 1

2
\$\begingroup\$

Boolean

This can be simplified, if you check a boolean, you don't need to check its value

Private Sub ExcelOptimization(ByVal turnState As Boolean)

If turnState = False Then
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
Else
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
End If

End Sub

So either start with

If Not turnState then

or swap it

If turnState then

Personally, I would use turnState = true for turning screenupdating and enableevents to true, so it's less confusing:

If turnState Then
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
Else
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
End If

And swap your calls in SplitCodes

In SplitCodes you do it again

If ValidateData(inputRange, currentSheetIndex) Then
    If RunSplitter(inputRange, currentSheetIndex) Then
        If RemoveCommas(inputRange, currentSheetIndex) Then

I like the nesting instead of using an If AND AND because you won't run functions unnecessarily.


Cancel input

You aren't handling a cancel event for

Set inputRange = Application.InputBox("Select single cell.", "Selection", Type:=8)

Function calls

It is excellent you're passing everything ByVal. However, I see the main sub is Private - how is it called?


Variable declaration

I see no added value in declaring variables on the same line like this-

Dim errorMessage As String, stringToFind As String
Dim countRows As Long, countArray As Long
Dim stringPosition As Long, stringCharacterCount As Long
Dim delimiterArray() As String

Additionally, something like countArray I would expect to be an array. And it seems you could use a constant for your string finding:

Const STRING_TO_FIND As String = "=|#"
Const DELIMITER As String = "|"
Dim errorMessage As String
Dim rowCount As Long
Dim arrayIndex As Long
Dim stringPosition As Long
Dim characterCount As Long
Dim delimiterArray() As String

You'll see by putting the constants at the top, you can change them once without needing to find them everywhere in the code.


LastRow

I think you're trying to get the last row here

countRows = Sheets(activesheetindex).Range(inputRange, inputRange.End(xlDown)).Rows.Count

There is a standard way to find lastRow and lastColumn. That post explains why.


Error handling

Looks like you have the same error handler everywhere, perhaps just declare it in the main sub and use error handling in each function to return a value that will trigger the error handler. Much better than repeating it a lot.


arrayString = vbNullString

awesome use of vbNullString - it's something a lot of people miss.


Function or Sub

You have a function here to return a boolean, but you also have things happening in the function. Functions should be used when something is returned and subs should be used when something happens. You can probably refactor that into several procedures. The same might be applicable for other functions.


ActiveSheet

Try to avoid things like activesheet and select - it's unclear. Since you're already finding the Sheet Index, you can create a worksheet variable for whatever worksheet you're on and use that instead of activesheet. It goes along with the comments of unqualified arguments.


On Error GoTo

What could go wrong?

I know it's pretty tempting to use the GoTo, but if you can, try to handle the error instead of waiting for the error. Anticipate what could error and find a way around the error. For instance:

countRows = Sheets(activesheetindex).Range(inputRange, inputRange.End(xlDown)).Rows.Count

What if this returns 0? Will other errors occur down the line? Why not handle it there

If countRows = 0 then GoTo ErrorHandler

But, instead of the goto, you can raise the Err and surround it in an If to pass it down to the handler. Or, create your own custom errors - which I think is probably beyond you right now, it's nearly beyond me, but I've done it.


Counting

This here -

stringCharacterCount = stringCharacterCount + 1
stringPosition = stringPosition + Len(stringToFind)
stringLastPosition = stringPosition

You don't reuse stringPosition before finding it again, so

stringLastPosition = 1
stringPosition = 1
stringToFind = delimiterArray(countArray)
Do
    stringPosition = InStr(stringLastPosition, ActiveSheet.Cells(counterRow, inputRange.Column), stringToFind, vbBinaryCompare)
    If stringPosition > 0 Then
        stringLastPosition = stringPosition + Len(stringToFind)
        stringCharacterCount = stringCharacterCount + 1
    End If
Loop While stringPosition > 0
\$\endgroup\$
2
  • \$\begingroup\$ Thank you for the 5* review! I will learn the custom errors, as I am very curious about it! Any good source you could provide? \$\endgroup\$
    – svacx
    Jan 20, 2017 at 17:46
  • 1
    \$\begingroup\$ I'd start here where I used it and got a lot of good feedback. Which started here. Be sure to correct some things and repost it for more review, I definitely didn't cover everything. \$\endgroup\$ Jan 20, 2017 at 17:56

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.