I'm developing a macro that converts a text file, hence the attempt for a funny title, or cringy, opinions may vary!
Context and Objectives
I was assigned a project to replace a old legacy program whose our contract is about to expire. This program accepted a text file for input and splits it into a new file based on a couple of parameters.
The text file does not have a clear structure, meaning that just separating with spaces, tabs or commas does not produce a clean file with all data.
So the objective of my macro is to input the text file and treat it, and separate it according to a spec, special format for a single case where there's a extra space and normalize it, and finally write to CSV.
As far as speed goes, I am not happy at all with it. It takes about 17 secs to
read, convert and output for a 4MB file, which has about 24 000 lines.
Probably I am doing some extra code that can be truncated and improved, but I need your wise eyes to help me.
Also, I've already run Rubberduck Build 2.0.11.
The test data and add-in:
There's some really basic error handling in here, I am learning custom error handling now, but I haven't include it here.
Upfront apologies for the length of the post.
Code
Outside from any sub, on top
Option Explicit '@Ignore EncapsulatePublicField, MoveFieldCloserToUsage Public progressBarCount As Long
Starting from the main sub that holds all the smaller functions. I've chosen this logic because it runs the procedures in a sequence and doesn't run unnecessary functions.
Public Sub ConvertPanel() Dim startCell As Range Dim readMethod As Variant Dim convertString As Variant Dim finalProcessor As Variant Dim specString As String Dim filePath As String ExcelOptimization (True) Set startCell = Worksheets(1).Range(Cells(1, 1), Cells(1, 1)) specString = GetSpecString filePath = GetFilePath If ValidateSpecString(specString) Then If ValidateInputFile(filePath) Then convertString = ConvertSpecString(specString) readMethod = QuickRead(filePath) finalProcessor = SplitColumns(readMethod, convertString, startCell) If finalProcessor Then If FormatYear Then If FormatAutocomm Then If FormatID Then If FormatHA Then If FormatProv Then If AddHeader Then If ReplaceSpaces Then If CleanupSpaces Then If WriteOutputCSV Then ExcelOptimization (False) MsgBox "Process completed and file generated!", vbOKOnly, "Complete!" Exit Sub End If End If End If End If End If End If End If End If End If End If End If End If End Sub
Small performance improvement sub
Private Sub ExcelOptimization(ByVal turnState As Boolean) If turnState Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Columns.AutoFit Else Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True ThisWorkbook.Activate ThisWorkbook.Worksheets(1).Activate End If End Sub
This function defines how the text file should be splitted.
Private Function GetSpecString() As String Dim customSpecString As Long customSpecString = MsgBox("Do you want to use default spec string?", vbYesNo + vbQuestion, "Custom spec string") If customSpecString = vbNo Then GetSpecString = Application.InputBox("Enter your custom string", "Custom string builder", Type:=2) If GetSpecString = False Then MsgBox "No string was chosen. The default string will be used." GetSpecString = "1,10,@|11,2,@|15,1,@|16,4,@|20,2,@|23,1,@|31,1,@|35,1,@|39,1,@|41,1,@|160,1,@|161,2,@|163,1,@|165,1,@|25,2,@|29,2,@|34,1" Exit Function End If Else GetSpecString = "1,10,@|11,2,@|15,1,@|16,4,@|20,2,@|23,1,@|31,1,@|35,1,@|39,1,@|41,1,@|160,1,@|161,2,@|163,1,@|165,1,@|25,2,@|29,2,@|34,1" Exit Function End If End Function
Standard open file from windows explorer
Private Function GetFilePath() As String Dim choiceNumber As Long Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False choiceNumber = Application.FileDialog(msoFileDialogOpen).Show If choiceNumber <> 0 Then GetFilePath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1) Exit Function Else MsgBox "No file was chosen. Please re-check!", vbCritical, "Error - no file selected" GetFilePath = vbNullString Exit Function End If Exit Function End Function
Basic validation for split string ( called spec string )
Private Function ValidateSpecString(ByVal specString As String) As Boolean If Len(specString) < 3 Then MsgBox "No spec found. Please re-check.", vbCritical, "Error" ValidateSpecString = False Exit Function End If If specString = vbNullString Then MsgBox "Field specs are incorrect or missing. Aborting!", vbCritical, "Error" ValidateSpecString = False Exit Function End If If InStr(specString, "|") = 0 Then MsgBox "Please specify that you have at least 2 fields. Example: 1,10|2,10" ValidateSpecString = False Exit Function End If ValidateSpecString = True End Function
Basic validation for input file
Private Function ValidateInputFile(ByVal fileName As String) As Boolean If Dir(fileName, vbNormal) = vbNullString Then MsgBox "No file found.", vbCritical, "Error" ValidateInputFile = False Exit Function End If ValidateInputFile = True End Function
Function to convert the input spec string to an array to use later
Private Function ConvertSpecString(ByVal specString As String) As String() Dim fieldsInfo() As String Dim inputString As String inputString = Replace(specString, Space(1), vbNullString) fieldsInfo = Split(inputString, "|") ConvertSpecString = fieldsInfo End Function
Function to read the file that should be quick which I've adapted it from this post
Private Function QuickRead(ByVal fileName As String) As String() Dim fileNumber As Long Dim stringRes As String Dim fileSize As Long fileNumber = FreeFile fileSize = FileLen(fileName) stringRes = Space(fileSize) Open fileName For Binary Access Read As #fileNumber Get #fileNumber, , stringRes Close fileNumber QuickRead = Split(stringRes, vbCrLf) End Function
Main engine of the project, grabs everything from text file and splits into excel spreadsheet from the spec string. You'll notice that there's a special case for a number '822343', which is the only case where there's an extra space that shouldn't be there and thus "fixed" like that. Also I use a class for a progress bar which I only adapted, but the main conception is from Zack Graber.
Private Function SplitColumns(ByVal lineArray As Variant, ByVal fieldsInfo As Variant, ByVal startCell As Range) As Boolean Dim indexCount As Long Dim stringRange As Range Dim fileInfo() As String Dim counterColumns As Long Dim counterRows As Long Dim counterOfElements As Long Dim numberOfElements As Long Dim lastRowCounter As Long '@Ignore SelfAssignedDeclaration Dim progressBar As New progressBar Dim convertedString As String Dim startTime As Double Dim secondsElapsed As Double startTime = Timer Set stringRange = startCell numberOfElements = 17 counterRows = 1 counterColumns = 1 With ActiveSheet lastRowCounter = .UsedRange.Rows(.UsedRange.Rows.Count).Row End With For indexCount = LBound(lineArray) To UBound(lineArray) For counterOfElements = 0 To numberOfElements - 1 If Left$(lineArray(indexCount), 6) = "822343" Then convertedString = Left$(lineArray(indexCount), 37) & Mid$(lineArray(indexCount), 39, Len(lineArray(indexCount)) + 1) fileInfo = Split(fieldsInfo(counterOfElements), ",") stringRange.EntireRow.Cells(counterRows, counterColumns).Value = Mid$(convertedString, CLng(fileInfo(0)), CLng(fileInfo(1))) counterColumns = counterColumns + 1 Else fileInfo = Split(fieldsInfo(counterOfElements), ",") stringRange.EntireRow.Cells(counterRows, counterColumns).Value = Mid$(lineArray(indexCount), CLng(fileInfo(0)), CLng(fileInfo(1))) counterColumns = counterColumns + 1 End If Next counterOfElements counterColumns = 1 counterRows = counterRows + 1 If UBound(lineArray) < 100 Then If UBound(lineArray) = 1 Then progressBarCount = 100 Else progressBarCount = (counterRows * 100) / lastRowCounter End If Else progressBarCount = (counterRows * 100) / UBound(lineArray) End If If UBound(lineArray) = 0 Then progressBarCount = 0 End If progressBar.Update progressBarCount, 100, "Processing records", True Next indexCount SplitColumns = True secondsElapsed = Round(Timer - startTime, 2) MsgBox "Macro run in " & secondsElapsed & " seconds." End Function
For the next couple of functions, I just format specific fields that are needed for our database system (please let me know if I should remove these).
Private Function FormatYear() As Boolean Dim maxRowNumber As Long Dim rowNumber As Long On Error GoTo FormatYearErrHandler maxRowNumber = (Cells(Rows.Count, 3).End(xlUp).Row) For rowNumber = 1 To maxRowNumber Cells(rowNumber, 4).Value = Cells(rowNumber, 4).Value & Format$(Cells(rowNumber, 5).Value, "00") Next rowNumber Columns(5).EntireColumn.Delete FormatYear = True Exit Function FormatYearErrHandler: FormatYear = False Exit Function End Function
Private Function FormatAutocomm() As Boolean
Dim maxRowNumber As Long
Dim rowNumber As Long
Dim valueString As String
On Error GoTo FormatAutocommErrHandler
ThisWorkbook.Worksheets(1).Activate
maxRowNumber = Cells(Rows.Count, 11).End(xlUp).Row
For rowNumber = 1 To maxRowNumber
valueString = Format$(Cells(rowNumber, 11).Value, "00")
Cells(rowNumber, 11).NumberFormat = "@"
Cells(rowNumber, 11).Value = valueString
valueString = vbNullString
Next rowNumber
FormatAutocomm = True
Exit Function
FormatAutocommErrHandler:
FormatAutocomm = False
Exit Function
End Function
Private Function FormatID() As Boolean
Dim maxRowNumber As Long
Dim rowNumber As Long
On Error GoTo FormatIDErrHandler
maxRowNumber = (Cells(Rows.Count, 1).End(xlUp).Row)
For rowNumber = 1 To maxRowNumber
Cells(rowNumber, 1).Value = Cells(rowNumber, 1) * 1
Next rowNumber
FormatID = True
Exit Function
FormatIDErrHandler:
FormatID = False
Exit Function
End Function
Private Function FormatHA() As Boolean
Dim maxRowNumber As Long
Dim rowNumber As Long
Dim valueString As String
On Error GoTo FormatAutocommErrHandler
ThisWorkbook.Worksheets(1).Activate
maxRowNumber = Cells(Rows.Count, 14).End(xlUp).Row
For rowNumber = 1 To maxRowNumber
valueString = Format$(Cells(rowNumber, 14).Value, "00")
Cells(rowNumber, 14).NumberFormat = "@"
Cells(rowNumber, 14).Value = valueString
valueString = vbNullString
Next rowNumber
FormatHA = True
Exit Function
FormatAutocommErrHandler:
FormatHA = False
Exit Function
End Function
Private Function FormatProv() As Boolean
Dim maxRowNumber As Long
Dim rowNumber As Long
Dim valueString As String
On Error GoTo FormatAutocommErrHandler
ThisWorkbook.Worksheets(1).Activate
maxRowNumber = Cells(Rows.Count, 15).End(xlUp).Row
For rowNumber = 1 To maxRowNumber
valueString = Format$(Cells(rowNumber, 15).Value, "00")
Cells(rowNumber, 15).NumberFormat = "@"
Cells(rowNumber, 15).Value = valueString
valueString = vbNullString
Next rowNumber
FormatProv = True
Exit Function
FormatAutocommErrHandler:
FormatProv = False
Exit Function
End Function
Adding some headers
Private Function AddHeader() As Boolean Dim arr(1 To 16) As String On Error GoTo AddHeaderErrHandler arr(1) = "a" arr(2) = "b" arr(3) = "c" arr(4) = "d" arr(5) = "f" arr(6) = "g" arr(7) = "h" arr(8) = "i" arr(9) = "j" arr(10) = "k" arr(11) = "l" arr(12) = "m" arr(13) = "n" arr(14) = "o" arr(15) = "p" arr(16) = "q" With Worksheets(1) .Range("A1").EntireRow.Insert .Range("A1:P1") = arr() End With AddHeader = True Exit Function AddHeaderErrHandler: AddHeader = False Exit Function End Function
Cleaning up data for sparse spaces
Private Function ReplaceSpaces() As Boolean Dim MyArray As Variant Dim rowCountArray As Long, columnCountArray As Long MyArray = ActiveSheet.UsedRange For rowCountArray = LBound(MyArray) To UBound(MyArray) For columnCountArray = LBound(MyArray, 2) To UBound(MyArray, 2) If MyArray(rowCountArray, columnCountArray) <> vbNullString Then If InStr(1, MyArray(rowCountArray, columnCountArray), " ") > 0 Then Cells(rowCountArray, columnCountArray).Value = WorksheetFunction.Substitute(MyArray(rowCountArray, columnCountArray), " ", "0") End If End If Next columnCountArray Next rowCountArray ReplaceSpaces = True End Function
Cleaning up data after used range, to prevent when writing csv to show up blanks
Private Function CleanupSpaces() As Boolean Dim fileWorksheet As Worksheet Dim lastRow As Long Dim lastColumn As Long Dim usedRows As Long Dim usedColumns As Long Set fileWorksheet = ActiveSheet With fileWorksheet lastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row lastColumn = .UsedRange.Columns(.UsedRange.Columns.Count).Column usedRows = .UsedRange.Row + .UsedRange.Rows.Count - 1 usedColumns = .UsedRange.Column + .UsedRange.Columns.Count - 1 .Range(.Cells(lastRow, lastColumn + 1), .Cells(lastRow + usedRows, lastColumn + usedColumns + 1)).Clear End With CleanupSpaces = True End Function
Finally, generating CSV file
Private Function WriteOutputCSV() As Boolean Dim fileName As String Dim fileDelimiter As String Dim fileString As String Dim fileLastRow As Long Dim fileLastCol As Long Dim counterRow As Long Dim counterCol As Long Dim binaryStream As ADODB.Stream Dim fileWorksheet As Worksheet Const adSaveCreateOverWrite As Variant = 2 Set fileWorksheet = ActiveSheet Set binaryStream = New ADODB.Stream fileName = Application.GetSaveAsFilename(vbNullString, "CSV File (*.csv), *.csv") fileDelimiter = ";" counterRow = 1 counterCol = 1 binaryStream.Charset = "UTF-8" binaryStream.Type = 2 binaryStream.Open With fileWorksheet fileLastRow = .Range("A" & .Rows.Count).End(xlUp).Row fileLastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column End With Do Until counterRow = fileLastRow + 1 Do Until counterCol = fileLastCol + 1 fileString = fileString & Chr$(34) & fileWorksheet.Cells(counterRow, counterCol).Value & Chr$(34) If counterCol <> fileLastCol Then fileString = fileString & fileDelimiter End If counterCol = counterCol + 1 Loop binaryStream.WriteText fileString, 1 counterRow = counterRow + 1 counterCol = 1 fileString = vbNullString Loop binaryStream.SaveToFile fileName, adSaveCreateOverWrite binaryStream.Close MsgBox "CSV generated successfully" WriteOutputCSV = True Sheets(fileWorksheet.Name).UsedRange.Delete End Function
progressBarCount
could be local toConvertPanel
and a parameter toSplitColumns
... is it used in another module? Because from the posted code I'm not sure what warrants'@Ignore MoveFieldCloserToUsage
, which seems a correct suggestion from Rubberduck. \$\endgroup\$