VBA - Extracting 3 Text Lines From Text files

[dj44]

Hi folks,

I have encountered another problem.

I am trying to modify the vba code to import 3 pieces of information from some text files.

Extract the Lines that contain or begin with

##100
XX
%%

I was so happy when i found this and thought i could change a few lines using the instring function - but it has deadlocked me again.

   Sub ImportFromTextfiles()
    http://stackoverflow.com/questions/35826629/how-to-import-specific-text-from-files-in-to-excel
   
    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


    Set folder = fso.GetFolder("C:\Users\DJ\Desktop\Import\")

    ' Set the starting point to write the data to
   
    
     '-Start Data at Row & Column
      Set cl = ActiveSheet.Cells(2, 3)

    
      For Each file In folder.Files
      Set FileText = file.OpenAsTextStream(ForReading)                 ' Open the file

       
        Do While Not FileText.AtEndOfStream                             ' Read the file one line at a time
        TextLine = FileText.ReadLine 'read line
            
            
            '---- Problem

'            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
            
            
            '---  Data Lines containing placeholders  to Extract
            If key = "##100" Then col = 1
            If key = "XX" Then col = 2
            If key = "VV" Then col = 2 + num
            If col Then
                cl.Offset(, col - 1).value = value ' Fill cell
            End If
        Loop

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

End Sub

I have spent a lot of time trying different ways to extract the lines but nothing works

I tried using if instring function as well

How can I just get the lines that I need in the columns

Thank you for your time - I really appreciate it

[Leith Ross]

Hello dj44,

I would be a great help if you attach a copy of the text file. It makes for a faster answer to your question.

[dj44]

Hello Leith,

it's just a normal text files laid that has some paragraphs in it. But i was intrested in specific lines.

##100  Hello From Me File A 

Video provides a powerful way to help you prove your point. When you click Online Video, you can paste in the embed code for the video you want to add.

For example, you can add a

XX  THIS LINE i would like to have  - just a line

When you apply styles, your headings change to match the new theme. Save time in Word with new buttons that show up where you need them.
some where later

%%  Hello I would like to import this line too

I have been working on it still - but oh dear its not coming to much fruition so far.

[Leith Ross]

Hello dj44,

I found a few inconsistencies in your example. You don't have "VV" which appears in your keys. "VV" is the only example you have with a number following it that determines the column it will go to on the worksheet. Makes wonder if there are others. You also fail to mention or provide an example of the final data layout on the worksheet.

It is the little things that make or break coding a solution that will work. This is why I asked for the text file. It is faster for me to scan a file and create a list of questions I can ask you all at once.

If you can not upload a file to this site then use a file sharing service and post a link to the file. If you don't feel comfortable doing that, I can provide you my email address.

[dj44]

Hello Leith,

Thank you for taking the time to investigate this,

My bad, Im really clumsy at explaining things and make a dogs dinner of code as ive been told off here before many a time

I have no clue about keys - that’s the first time I saw it.

The text files are not very structured - I could not upload it but between the 2 rulers

============================================
## General ventilation in the workplace:

Supervision

Further information

General ventilation in the workplace: Guidance for employers
HSG202 HSE Books 2000
ISBN 0 7176 1793 9

XX A new practical guide to complying with COSHH in the rubber industry
Guidance HSE Books 1997
ISBN 0 7176 1372 0

The selection, use and maintenance of respiratory protective equipment: A
practical guide
HSG53 (Second edition) HSE Books 1998
ISBN 0 7176 1537 5

Safe to breathe: Dust and fume control in the rubber industry
Leaflet IACL95
HSE Books 1995 (single copy free or priced packs of 10
ISBN 0 7176 0979 0

Controlling airborne contaminants in the workplace

Technical Guide TG7 British
Occupational Hygiene Society 1987
%% ISBN 0 9059 2742
================================================






I have a very baby script that can extract 1 line from a text file, but on this occasion there are 3 lines, and some one put in these placeholders, and I hate to have to copy and paste and go through the mess.

Screenshot_1.jpg

Yes those placeholders are not the best I must say so.

I could do a copy and replace to make them into a word if that’s any better, so may be the instring function can be used.

thank you for looking at this

[Leith Ross]

Hello dj,

That does help more, thanks.

1. The only values of interest are "##","XX", and "%%"?
2. When copied to the worksheet, do you want the prefix removed, i.e. "##", "XX", %%"?
3. Will the columns being used be "C", "D", and "E"?
4. Which row will be the starting row?
5. Are all the files in the folder text files (.txt or .csv)?

[dj44]

Hello Leith,

Hello dj,

That does help more, thanks.

1. The only values of interest are "##","XX", and "%%"? Yes
2. When copied to the worksheet, do you want the prefix removed, i.e. "##", "XX", %%"? Yes please
3. Will the columns being used be "C", "D", and "E"? Yes - I am very very bad with resizing cells, I never can understand - how it works
4. Which row will be the starting row? Row 10 please
5. Are all the files in the folder text files (.txt or .csv)? Text Files

I'm not very good with computers any way and sitting in my worn out leather chair to copy and paste
- which mind you i did as a challenge for about an hour, untill it got me.

Thes files were pdf then they some how became word and then someone butchered them into text, and i do have to open it
so if you can do anything very grateful

Thank Leith, hope its not disturbing your good saturday.

[Leith Ross]

Hello dj,

Thes files were pdf then they some how became word and then someone butchered them into text, and i do have to open it
so if you can do anything very grateful

Do this mean you need the text file to be opened, read, and remain open?

[dj44]

Hello Leith,

I was just saying originally they were pdf and ended up being text files.

They are just text files now in my folder.

[Leith Ross]

Hello dj,

Okay, just wanted to be sure.

[Leith Ross]

Hello DJ,

Sorry about the delay. I encountered a new problem I have never seen before in VBA and it was driving me crazy.

I just discovered that when using a For Each Loop with an array, you cannot exit the loop early and reload the array with new data. VBA moves the entire array into protected memory and locks it. The array will not be unlocked until the For Each Loop has iterated through all of the array elements. In working with VBA for 20 years I have never encountered this until now.

Anyway, that problem has solved and the code is working. It is long because I documented it very completely for you to be able to see and follow the logic.

Here is the macro that has been added to the attached workbook. The attached workbook has a button on the worksheet to run the macro. The macro is setup to allow you to select the folder where the files are. I did this to make it easy for troubleshooting. However, you can easily change the macro to use a fixed folder path. The directions are in the comments.

Macro Code

Sub ParseFiles()
    
    Dim Data()  As Byte
    Dim File    As Variant
    Dim Files   As Variant
    Dim Folder  As Object
    Dim Line    As Variant
    Dim Lines   As Variant
    Dim key     As Variant
    Dim Keys    As Variant
    Dim n       As Long
    Dim Path    As Variant
    Dim Rng     As Range
    Dim s       As Long
    Dim Text    As String
    Dim Wks     As Worksheet
    Dim x       As Long
    
        ' Strings to search for in the text.
        Keys = Array("##", "XX", "%%")
        
        ' Select Folder path of the text files to be parsed.
        With Application.FileDialog(msoFileDialogFolderPicker)
            .AllowMultiSelect = False
            .Show
            If .SelectedItems.Count > 0 Then
                Path = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With
        
        ' To use a fixed folder path, delete the With ... End With lines above.
        ' Remove the comment (single quote) from the line below. Change the path to your files.
        ' Path = "C:\Users\DJ\Desktop\Import\"
        
        Set Wks = ActiveSheet
        Set Rng = Wks.Range("C10")
        
        ' Clear any previous parsed text.
        Intersect(Rng.CurrentRegion, Rng.CurrentRegion.Offset(1, 0)).ClearContents
        
            ' Open the folder using it's path.
            With CreateObject("Shell.Application")
                Set Folder = .Namespace(Path)
            End With
        
            ' Check that the folder exists.
            If Folder Is Nothing Then
                MsgBox Path & " Not Found.", vbExclamation
                Exit Sub
            End If
        
            ' Return all files, links, and folders in the folder.
            Set Files = Folder.Items
        
            ' Filter out only text files.
            Files.Filter 64, "*.txt;*.csv"
                
                ' Step through each text file in the folder.
                For Each File In Files
                   ' Read all of the text into a byte array.
                    Open File.Path For Binary Access Read As #1
                        ReDim Data(LOF(1))
                        Get #1, , Data
                    Close #1
                    
                    ' Convert the byte array to a text string.
                    Text = StrConv(Data, vbUnicode)
                    
                    ' Divide the text into individual lines using the carriage return and line feed characters.
                    Lines = Split(Text, vbCrLf)
                    
                    ' Step through each line of text.
                    For x = 0 To UBound(Lines)
                        ' Remove any leading or trailing spaces.
                        Line = Trim(Lines(x))
                        
                        ' Search the line if it is not blank.
                        If Line <> "" Then
                            ' Check the line for each search term or key.
                            For Each key In Keys
                                ' Get key's position in the text line.
                                s = InStr(1, Line, key)
                                
                                ' If the key is found and is not just the key then paste the text after the key.
                                If s > 0 And s + Len(key) < Len(Line) Then
                                    Rng.Offset(0, n).Value = Mid(Line, s + Len(key), Len(Line) - s - Len(key) + 1)
                                    n = n + 1
                                End If
                                
                                ' Have all the keys been found? There are only 3 per file.
                                If n > UBound(Keys) Then GoTo NextFile
                            Next key
                        End If
                    Next x
NextFile:
                    ' Reset the column counter.
                    n = 0
                    ' Advance to the next row on the worksheet.
                    Set Rng = Rng.Offset(1, 0)
                Next File
            
End Sub

[dj44]

Hello Leith,

I can't begin to say what an outstanding generosity you have shown me, and you didn’t have to.

I am very bad at coding to begin with and their is some family emergency and i have do this work and my mind has been everywhere, drowning me.

You have given your time more than anything and that has really touched my heart,
like most folks on here this forum has some of the kindest and most selfless programmers since I joined.

And don’t get me wrong I always throw a spanner in the works because im very naïve and think I can change a few lines - but this is not that.


I always say its not easy coding after hours struggling with it. I cant find no software too that will do this for me.

There is no software that can do this job - so I try to have vba in my life since I learned of its existence.


Thank you so much for this kind gesture - lending your expert coding skills to the newbies and forum communitty, I hope they give great recognition to their members, I always say that.

Please forum I hope you recognise all the good talent and folks here, and sometimes me asking a dumb question
I hope does benefit losts of others who can use this exact thing as well as the pros - who can give kudos and credit for the stellar work shared here.


I send you the best of karma for your kindness and humanity


Thank you from your friend

dj

[Leith Ross]

Hello DJ,

You're welcome. The best thanks come when you have taught someone something new. When you can use that knowledge later on then I have done my job.

[bikeboy85]

Hello DJ,

You're welcome. The best thanks come when you have taught someone something new. When you can use that knowledge later on then I have done my job.

Leith

Thank you for your code, and coming to the rescue of the OP. I have a similar issue of parsing lines from a text file matching around 34 keywords in my file.

A specific textfile from my folder can be download from this link. https://uploadfiles.io/y9qur

I used the code you provided to the OP with the only modifications being the line on the worksheet where data is placed, the variant KEYS with my own keywords and I also commented out the line 'Intersect(Rng.CurrentRegion, Rng.CurrentRegion.Offset(1, 0)).ClearContents'

Here are the lines I modified :

Keys = Array("Mean RR  (ms)", "STD RR (ms)", "Mean HR (beats/min)", "STD HR (beats/min)", "Min HR (beats/min)", "Max HR (beats/min)", "RMSSD (ms)", "NNxx (beats)", "pNNxx (%)", "RR tri index", "TINN (ms)", "VLF (Hz)", "LF (Hz)", "HF (Hz)", "VLF (ms^2)", "LF (ms^2)", "HF (ms^2)", "VLF (log)", "LF (log)", "HF (log)", "VLF (%)", "LF (%)", "HF (%)", "LF (n.u.)", "HF (n.u.)", "Total power (ms^2)", "LF/HF ratio", "SD1 (ms)", "SD2 (ms)", "SD2/SD1 ratio", "Approximate entropy (ApEn)", "Sample entropy (SampEn)", "alpha 1", "alpha 2")

       
        Set Wks = ActiveSheet
        Set Rng = Wks.Range("A2")

I assigned the macro to a button on my sheet of interest.

When I run this code, a couple of observations in the parsed output on the excel sheet :

1. Minor issue - Certain data lines are parsed more than once into the column. This is happening exactly for the text lines for "VLF (Hz):" , "VLF (ms^2):", "VLF (log):". I'm guessing with a small tweak this can be fixed.

2. Major issue - The parsing stops after the text line for "SD2/SD1 ratio:" is copied. The last 4 keywords in KEYS is not parsed and the operation moves onto the next file. This happens for all the files. My guess is that the variant KEYS has an array limit. Or is it the memory of my system?

Please help with a tweak because your code does 95% of what I'm looking for...

Cheers !

[MEGAMETRO]

Hi there,

Great code above. I'm trying something similar, however my only alteration to the above would be to define the column which each key falls into.

The issue I have is that where some of the text files are missing a 'key' that found in others, the subsequent key is pasted in the 'wrong column' to the others. This makes for messy data from my side.

I've tried to define the keys as separate arrays, but I'm thinking this may not be right.

Can I please reach out and ask if there's an alteration to the code above that would allow the keys to be pasted into specific columns?

Any help would be greatly appreciated!

Thank you,

Luke

[Leith Ross]

Hello Luke,

I am confident the code can modified but I need a sample of the text and what the final layout should look like.

[MEGAMETRO]

Leith, thank you so much for offering to help! It's very generous of you!
For whatever reason, I can't upload the .txt files, so I've had to copy/paste and upload as word documents here (upload 1 and 2). These two files are examples where the 'event reason' outcome dictates a change to the recording of some of the headings.
In the case of upload 2, the 'To:' field is not recorded.
The 'From' and 'To' dates are essential data points for hundreds of files.
Where the 'status' ='Discon' a 'To' date is not required.

As mentioned earlier, if I use the code from 01-16-2017 below, this almost does the job. Only when 'Discon' files are in the mix, subsequent 'keys' get muddled up due to the missing 'To' column. If it could be somehow possible to force the keys into specific columns, that would do the trick!

For keys, the following would be useful to capture in specific columns:
A: Notification ID
B: TDD Descriptor
C: TDD number for the listing
D: From
E: To
F: QR Availability
G: Date of publication on the ARCC

Again, thank you for your support here. I noticed that the TRIM function doesn't quite work on these files as the separator between the 'key' and the value is a tab not a space. Anyway, I can look into that another day!

Thank you!
Luke

[Leith Ross]

Hello Luke,

I downloaded your Word files. It appears each document is a single record. Does each new record begin with a Time Event Notification?

[MEGAMETRO]

Hi Leith,

correct. Each .txt file is a unique record starting with time event notification.

thanks.
Luke

[Leith Ross]

Hello Luke,

Sorry for the delay. I decided to change the macro to make it more flexible. You can now choose which column each key will be output to. You can also change delimiter the file uses. Yours is set to a Tab character. Consecutive delimiters are treated as a single delimiter.

The files can contain multiple records as long as each record starts with the same line. The macro lets you select all of the CSV and TXT files in a folder of your choosing. You can change the filter if you need to.

The attached workbook has the macro added and a button to call it. The macros used in the workbook are shown below. If you have any problems or need more help let me know.

Macro Code

Option Explicit


' Thread:   http://www.vbaexpress.com/forum/showthread.php?58253-VBA-Extracting-3-Text-Lines-From-Text-files
' Poster:   MEGAMETRO (Luke)




Global SearchKeys   As Variant
Global strFS        As String   ' // Field Separator (delimiter string)
Global strNL        As String   ' // New Line character. PC uses CrLf, Mac uses Lf


Sub ParseRecords(ByRef Records As Variant)
    
    Dim Data    As String
    Dim Hdr     As Range
    Dim j       As Long
    Dim k       As Long
    Dim Key     As Variant
    Dim Line    As Variant
    Dim n       As Long
    Dim Rec     As Variant
    Dim Rng     As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet
    
        Set Wks = ThisWorkbook.Worksheets("Sheet1")
        
        Set Hdr = Wks.Range("A1:G1")
        Set Rng = Hdr.Offset(1, 0)
        Set RngEnd = Wks.Cells(Rows.Count, Hdr.Column).End(xlUp)
        
        If RngEnd.Row > Hdr.Row Then
            Set Rng = RngEnd.Offset(1, 0)
        End If
        
        If VarType(SearchKeys) = vbEmpty Then
            ' // SearchKeys: Key = What to look for, Item = Destination column number
            Set SearchKeys = CreateObject("Scripting.Dictionary")
            With SearchKeys
                .CompareMode = vbTextCompare
                .Add "Notification ID:", 1
                .Add "TDD Descriptor:", 2
                .Add "TDD number for this listing:", 3
                .Add "From:", 4
                .Add "To:", 5
                .Add "QR Availability:", 6
                .Add "Date of publication on the ARCC:", 7
            End With
        End If
        
            For Each Rec In Records
                For Each Line In Split(Rec, strNL)
                    ' // Skip empty lines
                    If Line <> "" Then
                        For Each Key In SearchKeys.Keys
                            ' // Locate the key
                            n = InStr(1, Line, Key)
                            ' // Extract the first non empty field after the key
                            If n > 0 Then
                                j = n + Len(Key)
                                ' // Check for consecutive delimiters after the key
                                Do
                                    k = (Mid(Line, j, Len(strFS)) = strFS)
                                    If k = 0 Then Exit Do
                                    j = j + Len(strFS)
                                Loop
                                ' // Check if field data is at the end of the line
                                If j < Len(Line) Then
                                    ' // Check for another field separator after the field data
                                    k = InStr(j, Line, strFS)
                                    If k = 0 Then k = Len(Line)
                                    Data = Mid(Line, j, k - j + Len(strFS))
                                    ' // Output the field data with no leading or trailing spaces
                                    Rng.Cells(1, SearchKeys(Key)).Value = Application.Trim(Data)
                                End If
                            End If
                        Next Key
                    End If
                Next Line
                ' // Move to the next output row
                Set Rng = Rng.Offset(1, 0)
            Next Rec
        
End Sub


Sub GetRecords()


    Dim Buffer()    As Byte
    Dim cnt         As Long
    Dim FileSpec    As Variant
    Dim n           As Long
    Dim Recs        As Variant
    Dim Text        As String
    
        ' // Initialize the delimiter and new line variables
        strFS = vbTab
        strNL = vbCrLf
        
        With Application.FileDialog(msoFileDialogOpen)
            .AllowMultiSelect = True
            .Filters.Add "Text Files", "*.csv,*.txt"
            .FilterIndex = .Filters.Count
            
            If .Show = -1 Then
                Application.ScreenUpdating = False
                
                For Each FileSpec In .SelectedItems
                    ' // Read the entire file as a byte aray.
                    Open FileSpec For Binary Access Read As #1
                        ReDim Buffer(LOF(1))
                        Get #1, , Buffer
                    Close #1
        
                    ' // Convert byte array back to a string
                    Text = StrConv(Buffer, vbUnicode)
        
                    ' // Identify each record in the file
                    Do
                        ' // Starting line of each record
                        n = InStr(n + 1, Text, "Time event Notification")
                        If n = 0 Then Exit Do
                        cnt = cnt + 1
                        If IsEmpty(Recs) Then
                            ReDim Recs(1 To 1)
                        Else
                            ReDim Preserve Recs(1 To cnt)
                        End If
                        ' // Save the starting character position of each record
                        Recs(cnt) = n
                    Loop
        
                    ' // Extract each record as a srting
                    For n = 1 To cnt
                        If n = cnt Then
                            Recs(n) = Mid(Text, Recs(n), Len(Text))
                        Else
                            Recs(n) = Mid(Text, Recs(n), Recs(n + 1) - 1)
                        End If
                    Next n
        
                    Call ParseRecords(Recs)
                Next FileSpec
                
                Application.ScreenUpdating = True
            End If
        End With
        
End Sub