A Moses's worthy string splitter

Question

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!

Answer 1

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