Use References in place of CreateObject
If you include the reference to the Microsoft Scripting Runtime you can reduce the dim and set of objFSO to
Dim fso As New Scripting.FileSystemObject
to increase readability. Note that i have removed the obj prefix as it is no longer dimmed as an object. Similarly, this can be done with the file as
Dim ScriptFile As Scripting.File
Doing this not only makes your code siginificantly easier to read, but also enables intellisense for these objects which makes it easier to write with them.
Make use of line continuation
You can use _ to allow for multi-line operations, and make your code more readable. For instance
OutputText = OutputText & "SET" & vbTab & "15-01" & vbTab & "(" & ArrayElementCounter & ",0,00)" & vbTab & vbDoubleQuote & ArrayForRange(ArrayElementCounter + 1, 1) & vbDoubleQuote & vbCrLf
can be formatted as
OutputText = _
OutputText & "SET" & vbTab & "15-01" & vbTab & _
"(" & ArrayElementCounter & ",0,00)" & vbTab & _
vbDoubleQuote & ArrayForRange(ArrayElementCounter + 1, 1) & _
vbDoubleQuote & vbCrLf
making it easier to read. Not that the _ must be preceded by a space and that you cannot have comments after the line continuation character
Consider using a named range for E3
To make your code more readable, you may consider naming the range E3 to something along the names of FilePath. You can do this by typing over the E3 that appears to the left of the function bar when E3 is selected or through the Name Manager under the Formulas ribbon menu.
This will allow you to reference the cell in VBA as ws.[FilePath] (where ws is your worksheet object) in place of ThisWorkbook.Sheets("Sheet1").Range("E3"). This will also make it so that if you move the named cell, you do not have to change the code (eg. if you insert a row it above for titling or something)
If you decide against this, you can still use the [...] notation to get this reference down to ws.[E3].
Consider using ListObjects
If you convert your table into a ListObject using CTRL + T while highlighting it, you can greatly reduce the complexity of some operations.
For instance if you define your listobject as lo, the row number of the last row can be found with
lo.Listrows.Count+lo.Range.Row
rather than
ws.Cells(Rows.Count, "B").End(xlUp).Row
Notably, the list object also allows for the data to be directly referenced with
lo.DataBodyRange
or for the iteration over lo as
For Each lr In lo.ListRows
where lr is a ListRow object
All Together
As you noted in your comments, it is faster to handle all the data by pushing it into an array, however, this can lead to memory issues with large datasets (particularlly if you are using 32 Bit Excel which has a 2GB memory limit). So, just to be thurough I have included two solutions, one which puts the data into a variant array, and one which iterates over the data using ListRows. While both are quick the iterative approach is ~6% slower.
Both solutions assume that the table as been converted to a listobject, and that the range E3 has been renamed to FilePath
Array Approach (for small lists)
Sub WriteToPCSFile_SmallList()
'----------------------------------------------------------------------------------------------------------
'Description of operations:
'----------------------------------------------------------------------------------------------------------
'
'First the sub grabs data from the listobject.
'Then the range containing the extensions and names is created using these variables.
'
'A file system object is created and a new .pcs file is created (represented by variable 'txtStream'
'The file path for the .pcs file is defined by the user on Sheet1 in range "FilePath" (E3)
'
'The range is put into an array as this is quicker than reading directly from each cell in the range.
'The output string (out) is built by concatanating itself with each array element contatining a name.
' Each iteration has a carraige return/line feed (chr(13)&chr(10)) at the end of the string so
' it's written on a new line
'
'The out string is then written to the .pcs file.
'
'==========================================================================================================
'------------ Set variables for our range and dynamically define the range of ext and names --------------=
'==========================================================================================================
Dim ws As Excel.Worksheet, _
lo As Excel.ListObject, _
dat As Variant, _
row As Long, _
out As String
'==========================================================================================================
'------------ Collect data -------------------------------------------------------------------------------=
'==========================================================================================================
Set ws = Application.ThisWorkbook.Worksheets("Sheet1")
Set lo = ws.[A1].ListObject
Let dat = lo.DataBodyRange.Value
If lo.ListRows.Count = 0 Then
Call MsgBox("Please enter at least 1 extension AND name!", vbCritical + vbOKOnly, "No Extension And Name")
Exit Sub
End If
'==========================================================================================================
'------------ Make out string ----------------------------------------------------------------------------=
'==========================================================================================================
For row = 1 To UBound(dat, 1)
If Not dat(row, 2) = Empty Then
Let out = out & _
"SET" & vbTab & "15-01" & vbTab & _
"(" & row - 1 & ",0,00)" & vbTab & _
vbDoubleQuote & dat(row, 2) & _
vbDoubleQuote & vbCrLf
End If
Next row
'==========================================================================================================
'------------ Create scripting file system object and create .pcs file to user defined path --------------=
'==========================================================================================================
Dim fso As New Scripting.FileSystemObject
Dim txtStream As Scripting.TextStream
Let UDFilePath = ws.[FilePath]
If UDFilePath = "" Then
Call MsgBox("Please enter a file path in cell E3 to save the script file to.", vbInformation, "Save Location Required")
Call ws.[FilePath].Select
Exit Sub
ElseIf Not Right(UDFilePath, 1) = "\" Then
Let UDFilePath = UDFilePath & "\" ''Error check to ensure back slash is last character
End If
On Error GoTo PathNotFound
Set txtStream = fso.CreateTextFile(UDFilePath & "out.txt", 2)
On Error GoTo 0
'==========================================================================================================
'------------ Write Data to the File ---------------------------------------------------------------------=
'==========================================================================================================
Call txtStream.Write(out)
Call txtStream.Close
Exit Sub
PathNotFound: '' Error handler if non valid file path is used (such as non existent path)
If Err.Number = 76 Then
Call MsgBox("Run time error (76) has occured." & vbNewLine & vbNewLine & _
"The following path does not exist or is not in a valid format:" & vbNewLine & _
vbDoubleQuote & UDFilePath & vbDoubleQuote & vbNewLine & vbNewLine & _
"Please check the path in cell E3 and try again.", _
vbCritical + vbOKOnly, "Invalid File Path")
Else '' Raise normal error if not due to invalid file path
Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)
End If
End Sub
Iterative Approach (for large lists)
Sub WriteToPCSFile_LargeList()
'----------------------------------------------------------------------------------------------------------
'Description of operations:
'----------------------------------------------------------------------------------------------------------
'
'First the sub grabs data from the listobject.
'Then the range containing the extensions and names is created using these variables.
'
'A file system object is created and a new .pcs file is created (represented by variable 'txtStream'
'The file path for the .pcs file is defined by the user on Sheet1 in range "FilePath" (E3)
'
'The range is iterated over, rather than being put into an array, as this is more memotry efficent, and
'the file is written to line by line
'
Dim ws As Excel.Worksheet, _
lo As Excel.ListObject, _
lr As Excel.ListRow, _
row As Long, _
out As String
'==========================================================================================================
'------------ Collect data -------------------------------------------------------------------------------=
'==========================================================================================================
Set ws = Application.ThisWorkbook.Worksheets("Sheet1")
Set lo = ws.[A1].ListObject
If lo.ListRows.Count = 0 Then
Call MsgBox("Please enter at least 1 extension AND name!", vbCritical + vbOKOnly, "No Extension And Name")
Exit Sub
End If
'==========================================================================================================
'------------ Create scripting file system object and create .pcs file to user defined path --------------=
'==========================================================================================================
Dim fso As New Scripting.FileSystemObject
Dim txtStream As Scripting.TextStream
Let UDFilePath = ws.[FilePath]
If UDFilePath = "" Then
Call MsgBox("Please enter a file path in cell E3 to save the script file to.", vbInformation, "Save Location Required")
Call ws.[FilePath].Select
Exit Sub
ElseIf Not Right(UDFilePath, 1) = "\" Then
Let UDFilePath = UDFilePath & "\" 'Error check to ensure back slash is last character
End If
On Error GoTo PathNotFound
Set txtStream = fso.CreateTextFile(UDFilePath & "out.txt", 2)
On Error GoTo 0
'==========================================================================================================
'------------ Write Data to the File ---------------------------------------------------------------------=
'==========================================================================================================
For Each lr In lo.ListRows '' iter over rows
If Not lr.Range(1, 2) = Empty Then '' write only if there is a name
Call txtStream.WriteLine( _
"SET" & vbTab & "15-01" & vbTab & _
"(" & row & ",0,00)" & vbTab & _
vbDoubleQuote & lr.Range(1, 2) & vbDoubleQuote)
End If
Let row = row + 1 '' iter row counter
Next lr
Call txtStream.Close '' close the file
Exit Sub
PathNotFound: 'Error handler if non valid file path is used (such as non existent path)
If Err.Number = 76 Then
Call MsgBox("Run time error (76) has occured." & vbNewLine & vbNewLine & _
"The following path does not exist or is not in a valid format:" & vbNewLine & _
vbDoubleQuote & UDFilePath & vbDoubleQuote & vbNewLine & vbNewLine & _
"Please check the path in cell E3 and try again.", _
vbCritical + vbOKOnly, "Invalid File Path")
Else 'Raise normal error if not due to invalid file path
Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)
End If
End Sub
