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!
Sheets
andCells
calls implicitly referring to the active worksheet, use of variant-returning string functions instead of the string-returning equivalents (e.g.Right
instead ofRight$
); 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\$Function RunSplitter() As Boolean
but does it have arguments? \$\endgroup\$Function RunSplitter(ByVal inputrange As Range, ByVal activesheetindex As Long) As Boolean
? \$\endgroup\$