FishingTrim

I’m not much of an angler these days. In my younger days, I pulled my share out of the Skunk River and lakes around central Iowa and southern Minnesota. Sit back and I’ll tell you a tale about the one that got away….

Kidding – today’s post is the third in a series about Microsoft Scripting in VBA. In the first post I covered the FileSystemObjct (FSO). In the second post, I looked at Regular Expressions (RegExp).

Previous posts:

  1. FileSystemObject (FSO)
  2. Regular Expressions

Today, I’ll look at the TextStream Object.

The TextStream Object

The TextStream Object enables you to read from and write to text files from Excel using VBA and the Microsoft Scripting Runtime Library (scrrun.dll)


    edit: I am going to use Late Binding in the sample snippets below. A discussion on Late / Early Binding is beyond the scope of this post. Please see these links for a detailed explanation of Late / Early Binding.

    1. Beyond Excel
    2. JP Software Technologies


Public Variables

Because I am using Late Binding, I’ll declare some Public Constants for working with the TextStream Object

Public Const gclForReading As Long = 1
Public Const gclForWriting As Long = 2
Public Const gclForAppending As Long = 8
Public Const gclTristateUseDefault As Long = -2
Public Const gclTristateTrue As Long = -1
Public Const gclTristateFalse As Long = 0

Tristate specifies the format of the text file:

  1. TristateUseDefault = -2 ; Opens the file using the system default
  2. TristateTrue = -1 ; Opens the file as Unicode
  3. TristateFalse = 0 ; Opens the file as ASCII

I also would like to create a function to let users choose a file or a folder. To use the function I’ll create global constants using the MsoFileDialogType Enumeration:

Public Const gclmsoFileDialogFilePicker As Long = 3
Public Const gclmsoFileDialogFolderPicker As Long = 4
Public Const gclmsoFileDialogOpen As Long = 1
Public Const gclmsoFileDialogSaveAs As Long = 2

CreateTextFile Method

I’ll use the CreateTextFile Method of the FileSystemObject (FSO) to create a TextStream Object and write a little message to the file:

Option Explicit
Sub WriteToText()

    'Author     :   Winston Snyder
    'Date       :   2/12/2014
    'Purpose    :   Write to a text file

    'Declare variables
        Dim fso             As Object
        Dim fsoFolder       As Object
        Dim fsoFile         As Object
        Dim ts              As Object
        Dim strFileName     As String
        Dim strFolderName   As String

    'Allow the user to choose a folder location to save the text file to
        strFolderName = GetFolder

    'Get file name from user
        strFileName = GetUserInput(strPrompt:="What would you like to name the file", _
                                   strTitle:="File Name")

    'Create a FileSystemObject (FSO)
        Set fso = GetFileSystemObject

    'Create a text file
        fso.CreateTextFile strFolderName & "\" & strFileName & ".txt"

    'Create an FSO file for the text file just created
        Set fsoFile = fso.GetFile(strFolderName & "\" & strFileName & ".txt")

    ' Open a TextStream for output.
        Set ts = fsoFile.OpenAsTextStream(gclForWriting, gclTristateUseDefault)

    ' Write to the TextStream
        ts.WriteLine "Jeff Weir"
        ts.WriteLine "is a prolific blogger!"
        ts.Close

    'Tidy up
        Set ts = Nothing
        Set fsoFile = Nothing
        Set fso = Nothing

End Sub

Textstream2

Append To A Text File

We don’t always want to create a new text file. Sometimes we want to append to an existing text file. We can use the OpenTextFile Method of the FileSystemObject:

Sub AppendToText()

    'Author     :   Winston Snyder
    'Date       :   2/15/2014
    'Purpose    :   Append to a text file

    'Declare variables
        Dim fso             As Object
        Dim fsoFile         As Object
        Dim ts              As Object
        Dim strFileName     As String

    'Allow the user to choose a file to append to
        strFileName = GetFile()

    'Create a FileSystemObject (FSO)
        Set fso = GetFileSystemObject

    'Create an FSO file for the text file just created
        Set fsoFile = fso.GetFile(strFileName)

    ' Open a TextStream for output.
        Set ts = fsoFile.OpenAsTextStream(gclForAppending, gclTristateUseDefault)

    ' Write to the TextStream
        ts.WriteLine
        ts.WriteLine "Mike Alexander is a handsome devil!"
        ts.Close

    'Tidy up
        Set ts = Nothing
        Set fsoFile = Nothing
        Set fso = Nothing

End Sub

At the GetFile() Dialog prompt, I chose the file I created in the “CreateTextFile Method”. I then used the constant, “gclForAppending” to specify that the new content was to be appended to the existing file. Had I used the constant, “gclForWriting”, the original contents would have been overwritten.

TextFileAppend2

The Functions

Here are the Functions() I used with the code snippets above

FileDialogFolderPicker

Public Function GetFolder() As String
 
    Dim fd As FileDialog
    Dim strFolderName As String
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
     
    With fd
        .Title = "Please select a folder"
        .AllowMultiSelect = False
        .Show
        strFolderName = .SelectedItems(1)
    End With
 
    GetFolder = strFolderName
     
    Set fd = Nothing
End Function

GetFileSystemObject

Public Function GetFileSystemObject() As Object
     
    On Error Resume Next
    Set GetFileSystemObject = CreateObject("Scripting.FileSystemObject")
     
End Function

GetUserInput

Public Function GetUserInput(strPrompt As String, _
                             strTitle As String) As String
     
    Dim strUserInput As String
     
    strUserInput = InputBox(Prompt:=strPrompt, _
                            Title:=strTitle)
                             
    GetUserInput = strUserInput
 
End Function

FileDialogFilePicker

Public Function GetFile() As String
 
    Dim fd As FileDialog
    Dim strFileName As String
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
     
    With fd
        .Title = "Please select a file"
        .AllowMultiSelect = False
        .Show
        strFileName = .SelectedItems(1)
    End With
 
    GetFile = strFileName
     
    Set fd = Nothing
End Function

The sample Procedures() given are fine for learning and understanding how to create text files and how to write and append data to the files. But how can we leverage these in a business environment to solve business needs and goals?

Merge Text Files

We may have a series of text files that we wish to merge into 1. Back in November, 2013, Ken Puls showed us how to use Power Query to import multiple text files into a Data Model (Power Pivot). All well and good. Let’s see if we can merge text files using the TextStream Object.

Here are some .csv files that I would like to merge together:

TextFilesForMerge

Sub MergeTextFiles()
    
    'Author     :   Winston Snyder
    'Date       :   2/15/2014
    'Purpose    :   Merge text files in a folder
    
    'Declare variables
        Dim fso                             As Object
        Dim fsoFolder                       As Object
        Dim fsoFileOutput                   As Object
        Dim fsoFile                         As Object
        Dim tsOutput                        As Object
        Dim tsInput                         As Object
        Dim strFolderInputFiles             As String
        Dim strFolderOutputFiles            As String
        Dim strFileName                     As String
        Dim strMisc                         As String

    'Allow the user to choose a folder that contains files to be merged
        strFolderInputFiles = GetFolder(strTitle:="Folder for files to be merged")
        
    'Allow the user to choose a folder location for the output file
        strFolderOutputFiles = GetFolder(strTitle:="Folder for output files")

    'What to name the output file
        strFileName = GetUserInput(strPrompt:="What would you like to name the file", _
                                   strTitle:="File Name")

    'Create a FileSystemObject (FSO)
        Set fso = GetFileSystemObject
        
    'Get an FSO folder for the input files
        Set fsoFolder = fso.GetFolder(strFolderInputFiles)
        
    'Create a text file for output
        fso.CreateTextFile strFolderOutputFiles & "\" & strFileName & ".txt"
        
    'Create an FSO file for the text file just created
        Set fsoFileOutput = fso.GetFile(strFolderOutputFiles & "\" & strFileName & ".txt")

    'Open a TextStream for output.
        Set tsOutput = fsoFileOutput.OpenAsTextStream(gclForAppending, gclTristateUseDefault)
        
    'Loop through the files in the input folder
        For Each fsoFile In fsoFolder.Files
            Set tsInput = fsoFile.OpenAsTextStream(gclForReading, gclTristateUseDefault)
            Do Until tsInput.AtEndOfStream
                strMisc = tsInput.ReadLine                  'Read from the input file
                tsOutput.WriteLine strMisc                  'Write to the output file
            Loop
        Next fsoFile
        
    'Tidy up
        Set tsInput = Nothing
        Set tsOutput = Nothing
        Set fsoFolder = Nothing
        Set fso = Nothing

End Sub

Here is the merged file.

MergedFilesMultipleHeaders

Pretty good, except the headers are repeating. I want to revise the code a bit to only include the header from the first file and skip the header on the subsequent files. The revised code:

Sub MergeTextFilesFirstFileHeader()
    
    'Author     :   Winston Snyder
    'Date       :   2/15/2014
    'Purpose    :   Merge text files in a folder
    'Comments   :   Only uses header row from the first file
    '               subsequent files, header row is skipped
    
    'Declare variables
        Dim fso                             As Object
        Dim fsoFolder                       As Object
        Dim fsoFileOutput                   As Object
        Dim fsoFile                         As Object
        Dim tsOutput                        As Object
        Dim tsInput                         As Object
        Dim strFolderInputFiles             As String
        Dim strFolderOutputFiles            As String
        Dim strFileName                     As String
        Dim strMisc                         As String
        Dim blnTest                         As Boolean
        
    'Initialize variables
        blnTest = True                                          'First time through loop

    'Allow the user to choose a folder that contains files to be merged
        strFolderInputFiles = GetFolder(strTitle:="Folder for files to be merged")
        
    'Allow the user to choose a folder location for the output file
        strFolderOutputFiles = GetFolder(strTitle:="Folder for output files")

    'What to name the output file
        strFileName = GetUserInput(strPrompt:="What would you like to name the file", _
                                   strTitle:="File Name")

    'Create a FileSystemObject (FSO)
        Set fso = GetFileSystemObject
        
    'Get an FSO folder for the input files
        Set fsoFolder = fso.GetFolder(strFolderInputFiles)
        
    'Create a text file for output
        fso.CreateTextFile strFolderOutputFiles & "\" & strFileName & ".txt"
        
    'Create an FSO file for the text file just created
        Set fsoFileOutput = fso.GetFile(strFolderOutputFiles & "\" & strFileName & ".txt")

    'Open a TextStream for output.
        Set tsOutput = fsoFileOutput.OpenAsTextStream(gclForAppending, gclTristateUseDefault)
        
    'Loop through the files in the input folder
        For Each fsoFile In fsoFolder.Files
            Set tsInput = fsoFile.OpenAsTextStream(gclForReading, gclTristateUseDefault)
            If blnTest = True Then
                blnTest = False
            Else
                tsInput.SkipLine                            'Move the file pointer to the line below the header
            End If
            Do Until tsInput.AtEndOfStream
                strMisc = tsInput.ReadLine                  'Read from the input file
                tsOutput.WriteLine strMisc                  'Write to the output file
            Loop
        Next fsoFile
        
    'Tidy up
        Set tsInput = Nothing
        Set tsOutput = Nothing
        Set fsoFolder = Nothing
        Set fso = Nothing

End Sub

MergedFilesOneHeader

Awesome! The solution was to use the SkipLine Method of the TextStream Object everytime through the loop other than the first time:

If blnTest = True Then
   blnTest = False
Else
   tsInput.SkipLine                        'Move the file pointer to the line below the header
End If

Read From Text File

Another common problem, is to read the contents of a text file into Excel. I’ll demonstrate some code to take care of this using comma separated values (csv), but you can use any kind of delimiter such as tab, space, pipe “|”, etc….

Sub ReadTextFileIntoExcel()
    
    'Author     :   Winston Snyder
    'Date       :   2/15/2014
    'Purpose    :   Read data from text file, output to Excel
    
    'Declare variables
        Dim fso                         As Object
        Dim fsoFile                     As Object
        Dim ts                          As Object
        
        Dim vArrData()                  As Variant
        Dim strLine()                   As String
        Dim strData()                   As String
        
        Dim i                           As Long
        Dim j                           As Long
        
        Dim strTextFileName             As String
        Dim strFolderOutputFiles        As String
        Dim strExcelFileName            As String
        Dim strReadAll                  As String
        
    'User - choose a text file to read into Excel
        strTextFileName = GetFile()
        
    'User - choose a folder location for the output file
        strFolderOutputFiles = GetFolder(strTitle:="Folder for output files")

    'User - name the output file
        strExcelFileName = GetUserInput(strPrompt:="What would you like to name the file", _
                                        strTitle:="File Name")

    'Create a FileSystemObject (FSO)
        Set fso = GetFileSystemObject
        
    'Create an FSO file for the user selected text file
        Set fsoFile = fso.GetFile(strTextFileName)

    'Open a TextStream for reading
        Set ts = fsoFile.OpenAsTextStream(gclForReading, gclTristateUseDefault)
        
    'Read the text file and store it in a string variable
        strReadAll = ts.ReadAll
    
    'Split each line of the text document based on the new line delimiter
        strLine = Split(strReadAll, vbNewLine)
        
    'Get number of elements in the line
        strData = Split(strLine(0), ",")
        
    'Redim the data array
        ReDim vArrData(LBound(strData) To UBound(strData), LBound(strLine) To UBound(strLine))
        
    'Erase the strData Array
        Erase strData
        
    'Loop the strLine Array, split each line into data elements, load the data elements into the data array
        For i = LBound(strLine) To UBound(strLine)
            strData = Split(strLine(i), ",")
            For j = LBound(strData) To UBound(strData)
                vArrData(j, i) = strData(j)
            Next j
        Next i

    'Output the array to an Excel Worksheet
        Call ArrayToRange(vArr:=vArrData, _
                          strPath:=strFolderOutputFiles, _
                          strFileName:=strExcelFileName)
        
    'Tidy up
        'Erase arrays
            Erase vArrData
            Erase strLine
            Erase strData
            
        'Destroy objects
            Set ts = Nothing
            Set fsoFile = Nothing
            Set fso = Nothing

End Sub

'----------------------------------------------------------------------------------------

Public Sub ArrayToRange(ByRef vArr() As Variant, _
                        strPath As String, _
                        strFileName As String)
                        
    Dim wbNew As Workbook
    Dim wsNew As Worksheet
    Dim rngNew As Range
    Dim r As Long
    Dim c As Long
    
    c = UBound(vArr, 1)                                     '1st dimension of array
    r = UBound(vArr, 2)                                     '2nd dimension of array
    
    Set wbNew = Workbooks.Add
    Set wsNew = wbNew.Worksheets("Sheet1")
    Set rngNew = wsNew.Range("A1")

    'Resize the destination range
    'Use +1, +1 for Rows and columns since array begins at (0,0)
        rngNew.Resize(r + 1, c + 1).Value = Application.Transpose(vArr)
    
    wbNew.SaveAs strPath & "\" & strFileName & ".xlsx"
    wbNew.Close
    
    Set rngNew = Nothing
    Set wsNew = Nothing
    Set wbNew = Nothing
    
End Sub

TextToExcelFinal

Tidy Up

That’s it for today. Long post, sorry ’bout that. That last snjppet ended up being about Arrays as much as it was about the TextStream Object. Now, where did I leave my worms? I’m going fishing.

Download the file from SkyDrive

Previous Posts At dataprose.org – Scripting

  1. The FileSystemObject
  2. Regular Expressions

Microsoft Scripting

  1. Microsoft Scripting Center
  2. FileSystemObject Reference (Windows Scripting)
  3. TextStream Object
  4. 4 Guys From Rolla – FSO

Additional Resources – Arrays

  1. VBA Arrays And Worksheet Ranges
  2. Understanding Arrays
  3. Redim Statement
, , , ,