3
\$\begingroup\$

I'm a newbie PABX tech with a hobby for programming so when I learnt most of the telephone system programming can be completed with scripts I got curious.

With a bit of trial and error to work out the seemingly undocumented syntax of the script I decided once I'd cracked it, to create a spreadsheet where the user enters a list of names in an excel sheet (in column B from row 2) and then clicks a CommandButton to create a script to easily input the name list for the telephone extensions into the system.

I've chosen VBA as my preferred language as

  1. I'm most competent in VBA, and
  2. It's common to copy/paste a list from excel already (it's just slightly more tedious that way in my oppinion)

I've not had much experience writing to external files (other than other office applications) so I'm looking to see if there are any more efficient ways to achieve this than the way I have with FSOs.

General housekeeping is welcomed too, so any improvements in the way it's written; order of the code, efficiencies elsewhere etc.

The comments are aimed at someone who has very little VBA experience as as far as I know I'm the only person familiar with it in the office.

Public Sub WriteNamesInRangeToPCSFile()
'Description of operations:
'----------------------------------------------------------------------------------------------------------
'
'First the sub finds the last row of column B.
'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 'objScriptFile'
'The file path for the .pcs file is defined by the user on Sheet1 in cell C1
'
'The range is put into an array as this is more efficient than reading directly from each cell in the range.
'The output string is built by concatanating itself with each array element contatining a name.
'      Each iteration has a carraige return/line feed (chr(9)) at the end of the string so it's written on a new line
'
'The OutputText string is then written to the .pcs file.
'
'==========================================================================================================
'------------ Set variables for our range and dynamically define the range of ext and names --------------=
'==========================================================================================================
Dim PopulatedRangeOfNamesAndExtensions As Range
Dim LastRow As Long

With ThisWorkbook.Sheets("Sheet1")
    LastRow = .Cells(Rows.Count, "B").End(xlUp).Row

    If LastRow = 1 Then
        MsgBox "Please enter at least 1 extension AND name!", vbCritical + vbOKOnly, "No Extension And Name"
        Exit Sub
    Else
        Set PopulatedRangeOfNamesAndExtensions = .Range(Cells(2, "B"), Cells(LastRow, "B"))
    End If
End With

'==========================================================================================================
'------------ Create scripting file system object and create .pcs file to user defined path --------------=
'==========================================================================================================
Dim objFSO As Object
Dim objScriptFile As Object
Dim UDFilePath As String

UDFilePath = ThisWorkbook.Sheets("Sheet1").Range("E3").Value
If UDFilePath = "" Then
    MsgBox "Please enter a file path in cell E3 to save the script file to.", vbInformation, "Save Location Required"
    ThisWorkbook.Sheets("Sheet1").Range("E3").Select
    Exit Sub
ElseIf Not Right(UDFilePath, 1) = "\" Then
    UDFilePath = UDFilePath & "\" 'Error check to ensure back slash is last character
End If

Set objFSO = CreateObject("Scripting.FileSystemObject")

On Error GoTo PathNotFound
Set objScriptFile = objFSO.CreateTextFile(UDFilePath & "NEC_15-01_Names_Script.pcs", 2)
On Error GoTo 0

'==========================================================================================================
'------------ Build our output string by dumping the data to an array and looping the array --------------=
'==========================================================================================================
Dim OutputText As String
Dim ArrayElementCounter As Long
Dim ArrayForRange As Variant

ArrayForRange = PopulatedRangeOfNamesAndExtensions

For ArrayElementCounter = 0 To (UBound(ArrayForRange) - 1)
    If Not ArrayForRange(ArrayElementCounter + 1, 1) = Empty Then     'counter + 1 because counter is zero based and array is 1 based
        OutputText = OutputText & "SET" & vbTab & "15-01" & vbTab & "(" & ArrayElementCounter & ",0,00)" & vbTab & vbDoubleQuote & ArrayForRange(ArrayElementCounter + 1, 1) & vbDoubleQuote & vbCrLf
    End If
Next ArrayElementCounter

'Write the built output string to the newly created .pcs file.
objScriptFile.Write (OutputText)

Exit Sub        'Exit before error handler is run.

PathNotFound:   'Error handler if non valid file path is used (such as non existent path)
If Err.Number = 76 Then
    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
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If

End Sub

The scripts are tab-spaced with the syntax:
SET <Memory-Block> (parameters) "Value"
Where (Parameters) further breaks down to (<Row>,<Column>,<Item>)

It should be noted that the parameters are zero-based - i.e the first row, column and item is 0 (though in the system it's shown in the GUI as 1 just to make things confusing).


Here are some example screenshots of source data and the output file:

Source data on sheet:
Source data sample

Output file:
Output file saved in user defined location

For bonus points here is a snip of the system after running the output script file:
System after running output script file

\$\endgroup\$

1 Answer 1

2
\$\begingroup\$

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 & "NEC_15-01_Names_Script.pcs", 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 & "NEC_15-01_Names_Script.pcs", 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
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.