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!

• Mathieu Guindon: 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?
• user34073: 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.
• Raystafarian: 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?
• Raystafarian: Maybe it's Function RunSplitter(ByVal inputrange As Range, ByVal activesheetindex As Long) As Boolean?
• svacx: @Raystafarian sorry it was a edit issue! should look better now

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

• svacx: 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?
• Raystafarian: 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.