How to import specific text from files in to excel?

Question

I found this code by @Scott Holtzman and I need to tweek it a bit to match my needs. This code takes each line in a text file and puts it into seperate columns in an excel sheet(A1, B1, C1 and so on), each text file is stored in a seperate row(1,2,3 and so on). First i want it to only put text into the excel sheet if the line starts with a specific text, second i want it to only copy some of the text from each line into the excel sheet.

Sub ReadFilesIntoActiveSheet()

Dim fso As FileSystemObject
Dim folder As folder, file As file, FileText As TextStream
Dim TextLine As String, Items() As String
Dim i As Long, cl As Range

' Get a FileSystem object
Set fso = New FileSystemObject

' get the directory you want
Set folder = fso.GetFolder("D:\YourDirectory\")

Dim x As Long
x = 1 'to offset rows for each file

' Loop thru all files in the folder
For Each file In folder.Files

' set the starting point to write the data to
Set cl = ActiveSheet.Cells(x, 1)

' Open the file
Set FileText = file.OpenAsTextStream(ForReading)

Dim j As Long
j = 0 'to offset columsn for each line
' Read the file one line at a time
Do While Not FileText.AtEndOfStream

    TextLine = FileText.ReadLine 'read line

    cl.Offset(, j).Value = TextLine 'fill cell

    j = j + 1
Loop

' Clean up
FileText.Close

x = x + 1

Next file

Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing

End Sub

Here is what my text files look like:

From:NameName           'want all text except the "FROM:"
Date:yyyy.mm.dd         'want all text except the "Date:"
Type: XXXXXXXXX         ' I don't want this line into excel
To: namename            ' I don't want this line into excel

----------------------------- xxxxxxx ---------------------
A1: Tnr xxxxxxxxxxxxx   'want all text except the "A1: Tnr" only next 13char
A2: texttext            'want all text except the "A2:"
An:                     'A1 and up to A14
A14: texttext           'want all text except the "A14:"  

------------------------------ xxxxxx ----------------------

So in total there is 22 lines in the text file.

And if it is possible to use the FROM:, DATE:, A1: to A14: as headers in the first row that would be epic.

have tried to google my way to it, and tried a bit with this:

TextLine =    FileText.ReadLine 'read line
If InStr(TextLine, "A1:") 

but that works only for one line and i cant seem to get it to work with several lines. In addition it puts the output in cell F1, instead of A1. think this is since each line in text document gets one cell - even if nothing is written to it.

Answer 1

Replace the "Do While's" body with the following lines

TextLine = FileText.ReadLine 'read line
If Not (Left(TextLine, 1) = "T" Or Left(TextLine, 1) = "-") Then
    TextLine = Trim(Mid(TextLine, InStr(TextLine, ":") + 1))
    If (TextLine <> "") Then
       cl.Offset(, j).Value = TextLine 'fill cell
       j = j + 1
    End If
End If

Answer 2

Here is a solution that fills one row in the Excel sheet per file, starting at row 2. You should manually fill in the titles in that first row as follows:

From | Date | A1 | A2 | ... | A14

The lines that you are not interested in are skipped, and the values are put in the correct columns:

Sub ReadFilesIntoActiveSheet()
    Dim fso As FileSystemObject
    Dim folder As folder, file As file, FileText As TextStream
    Dim TextLine As String
    Dim cl As Range

    Dim num As Long ' numerical part of key, as in "Ann:"
    Dim col As Long ' target column in Excel sheet
    Dim key As String ' Part before ":"
    Dim value As String ' Part after ":"

    ' Get a FileSystem object
    Set fso = New FileSystemObject

    ' Get the directory you want
    Set folder = fso.GetFolder("D:\YourDirectory\")

    ' Set the starting point to write the data to
    ' Don't write in first row where titles are
    Set cl = ActiveSheet.Cells(2, 1)

    ' Loop thru all files in the folder
    For Each file In folder.Files
        ' Open the file
        Set FileText = file.OpenAsTextStream(ForReading)

        ' Read the file one line at a time
        Do While Not FileText.AtEndOfStream

            TextLine = FileText.ReadLine 'read line

            key = Split(TextLine & ":", ":")(0)
            value = Trim(Mid(TextLine, Len(key)+2))
            num = Val(Mid(key,2))
            If num Then key = Replace(key, num, "") ' Remove number from key
            col = 0
            If key = "From" Then col = 1
            If key = "Date" Then col = 2
            If key = "A"    Then col = 2 + num
            If col Then
                cl.Offset(, col-1).Value = value ' Fill cell
            End If
        Loop

        ' Clean up
        FileText.Close
        ' Next row
        Set cl = cl.Offset(1) 
    Next file
End Sub

The above code will work well even if items are missing in your file, like if the line with "A12:" would not be present, this will leave the corresponding cell in the sheet empty, instead of putting the value of "A13:" there, causing a shift.

Even if the order of the lines would change, and "From:" would appear after "Date:", this will not have a negative effect in the output. "From" values will always get into the first column, "Date" values in the second, etc.

Also, if your file would contain many other lines with differing formats, they will all be ignored.