Excel reading from text files RRS feed

  • Question

  • Hello, I am curious if you can help me complete a task. I am looking to take multiple text files with the same formatting, and I need to get most of the information from the file(Driver Name, Tractor#, Trailer#, and remarks/comments) and have it placed into a google sheet/excel worksheet. The google sheet I am working on will need to be able to hold multiple truck problem files information so we have an idea of where our mechanic team is and how many trucks they are working on. I have started by creating a macro that can read a text file and pull some information from it however I need to be able to pull all of these fields from the text file. I have included the macro's I have created so far (It can read multiple text files) as well as I can add how our text files look if need be and an example of how I would like the output to look.  I have a main module, and a class that holds the data(both attached)    For example: 

    Driver Name      |     Tractor#    |     Trailer#     |      Remarks

    John Prellana     |        586        |          3          |      Scratches in the trailer

    'Main Module
    Option Explicit
    'NOTE:  Set reference to Microsoft Scripting Runtime
    Sub FindInFile()
        Dim sBaseFolder As String, sFindText As String, sFindTracNum As String, sFindTrailNum As String, sFindRemarks As String
        Dim FD As FileDialog
        Dim FSO As FileSystemObject, FIs As Files, FI As File, FO As Folder
        Dim TS As TextStream
        Dim colL As Collection, TracNum As Collection, TrailNum As Collection, Remarks As Collection, cL As cLines
        Dim S As String, strPath As String
        Dim I As Long
        Dim R As Range
        Dim wsRes As Worksheet, rRes As Range, vRes() As Variant
    'Set results worksheet and range
    Set wsRes = Worksheets("Sheet1")
    Set rRes = wsRes.Cells(1, 1)
    sFindText = "Driver Name:"
    sFindTracNum = "Tractor Numner:"
    sFindTrailNum = "Trailer Numner:"
    sFindRemarks = "Remarks:"
    'Specify the folder
    strPath = "C:\test\Excel Test"
    'Get the Text files in the folder
    Set FSO = New FileSystemObject
    Set FO = FSO.GetFolder(strPath)
    Set FIs = FO.Files
    'Collect the information
    Set colL = New Collection
    Set TracNum = New Collection
    Set TrailNum = New Collection
    Set Remarks = New Collection
    For Each FI In FIs
    With FI
        If .Name Like "*.txt" Then
            I = 0
            Set TS = FSO.OpenTextFile(strPath & "\" & .Name, ForReading)
            Do Until TS.AtEndOfStream
                S = TS.ReadLine
                I = I + 1
                Set cL = New cLines
                If InStr(1, S, sFindText, vbTextCompare) > 0 Then
                    With cL
                        .LineText = S
                    End With
                    colL.Add cL
                End If
                If InStr(1, S, sFindTracNum, vbTextCompare) > 0 Then
                    With cL
                        .LineText = S
                    End With
                    colL.Add cL
                End If
        End If
    End With
    Next FI
    'Write the collection to a VBA array
    ReDim vRes(0 To colL.Count, 1 To 6)
    'Column Headers
    vRes(0, 1) = "Driver Name"
    vRes(0, 2) = "Tractor#"
    vRes(0, 3) = "Trailer#"
    vRes(0, 4) = "Remarks"
    vRes(0, 5) = "Next" & vbLf & "Plan"
    vRes(0, 6) = "Status" & vbLf & "of" & vbLf & "Repairs"
    For I = 1 To colL.Count
    With colL(I)
        vRes(I, 1) = .LineText
        vRes(I, 2) = .TracNum
        vRes(I, 3) = .TrailNum
        vRes(I, 4) = .Remarks
    End With
    Next I
    'Write to the worksheet
    Application.ScreenUpdating = False
    Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
    With rRes
        .Value = vRes
        With .Rows(1)
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        End With
        .EntireColumn.ColumnWidth = 45
        With .EntireRow
            .WrapText = True
            .VerticalAlignment = xlCenter
        End With
        'Remove the FindWord
        For Each R In rRes.Offset(1).Resize(rRes.Rows.Count - 1).Columns(1).Cells
            I = 1
                I = InStr(I, R.Text, sFindText, vbTextCompare)
                With R.Characters(I, Len(sFindText))
                End With
                I = InStr(I + 1, R.Text, sFindText, vbTextCompare)
            Loop Until I = 0
        Next R
    End With
    Application.ScreenUpdating = True
    End Sub
    'cLines class
    Option Explicit
    Private pLineNum As String
    Private pLineText As String
    Private pFolderPath As String
    Private pFileName As String
    Public Property Get TracNum() As String
        TracNum = pLineNum
    End Property
    Public Property Let TracNum(Value As String)
        pLineNum = Value
    End Property
    Public Property Get LineText() As String
        LineText = pLineText
    End Property
    Public Property Let LineText(Value As String)
        pLineText = Value
    End Property
    Public Property Get TrailNum() As String
        TrailNum = pFolderPath
    End Property
    Public Property Let TrailNum(Value As String)
        pFolderPath = Value
    End Property
    Public Property Get Remarks() As String
        Remarks = pFileName
    End Property
    Public Property Let Remarks(Value As String)
        pFileName = Value
    End Property

    Thursday, April 18, 2019 9:44 PM