Copy specified data from notepad to excel

Can you attach a copy of your workbook? Or at least clarify the following:
Do you need to always loop through all txt files in folder or only those which names are in column A?
Where on the worksheet should the extracted text go to, column C?

Originally Posted by dOOb

Can you attach a copy of your workbook? Or at least clarify the following:
Do you need to always loop through all txt files in folder or only those which names are in column A?
Where on the worksheet should the extracted text go to, column C?

Hello dOOb,

Loop through Only those names in column A. The data should be extracted to column b,c...Etc., depending on the headers in the row 1.

Let me know if this works:

Sub NewSub()

    Dim FSO As Object
    Dim Fld_obj As Object
    Dim File_obj As Object
    Dim FilePath As String
    Dim Hdr As String
    Dim myStr As String
    Dim myTxtFile
    Dim Txt_arr
    Dim i As Long
    Dim r As Long
    Dim c As Long

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Fld_obj = FSO.GetFolder("C:\Text Files") 'update to your own folder
    
    With ActiveSheet
        For c = 2 To .UsedRange.Columns.Count 'define your end value differently if needed
            Hdr = .Cells(1, c).Value
            
            For r = 2 To .UsedRange.Rows.Count 'as above
                Filename = .Cells(r, 1).Value
                If FSO.FileExists(Fld_obj & "\" & Filename) Then
                    FilePath = Fld_obj & "\" & Filename
                    
                    Set myTxtFile = FSO.OpenTextFile(FilePath, ForReading) 'this reads the file to "memory"
                    Txt_arr = Split(myTxtFile.ReadAll, vbNewLine) 'this splits the text into array
                    
                    For i = 0 To UBound(Txt_arr) 'loop through text, find line matching the header
                        If Txt_arr(i) = Hdr Then
                            Do Until Txt_arr(i) Like "*------*" 'iterate until the "-----" line is found
                                If myStr = vbNullString Then
                                    myStr = Txt_arr(i) & vbNewLine
                                Else
                                    myStr = myStr & Txt_arr(i) & vbNewLine
                                End If
                                i = i + 1
                            Loop
                            .Cells(r, c).Value = myStr 'populate data in worksheet
                            myStr = vbNullString
                            Exit For
                        End If
                    Next i
                End If
            Next r
        Next c
    End With
    
End Sub

Originally Posted by dOOb

Let me know if this works:

Sub NewSub()

    Dim FSO As Object
    Dim Fld_obj As Object
    Dim File_obj As Object
    Dim FilePath As String
    Dim Hdr As String
    Dim myStr As String
    Dim myTxtFile
    Dim Txt_arr
    Dim i As Long
    Dim r As Long
    Dim c As Long

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Fld_obj = FSO.GetFolder("C:\Text Files") 'update to your own folder
    
    With ActiveSheet
        For c = 2 To .UsedRange.Columns.Count 'define your end value differently if needed
            Hdr = .Cells(1, c).Value
            
            For r = 2 To .UsedRange.Rows.Count 'as above
                Filename = .Cells(r, 1).Value
                If FSO.FileExists(Fld_obj & "\" & Filename) Then
                    FilePath = Fld_obj & "\" & Filename
                    
                    Set myTxtFile = FSO.OpenTextFile(FilePath, ForReading) 'this reads the file to "memory"
                    Txt_arr = Split(myTxtFile.ReadAll, vbNewLine) 'this splits the text into array
                    
                    For i = 0 To UBound(Txt_arr) 'loop through text, find line matching the header
                        If Txt_arr(i) = Hdr Then
                            Do Until Txt_arr(i) Like "*------*" 'iterate until the "-----" line is found
                                If myStr = vbNullString Then
                                    myStr = Txt_arr(i) & vbNewLine
                                Else
                                    myStr = myStr & Txt_arr(i) & vbNewLine
                                End If
                                i = i + 1
                            Loop
                            .Cells(r, c).Value = myStr 'populate data in worksheet
                            myStr = vbNullString
                            Exit For
                        End If
                    Next i
                End If
            Next r
        Next c
    End With
    
End Sub

Thanks for your effort dOOb! But unfortunately this isn't working as expected.

as requested earlier, please find the attached sample sheet.

I found this code on the web and this is working fine for one file at a time and displays the output in a msgbox.

Is it possible to modify the code to loop through a set of files in a folder and fetch the data as an output to an excel sheet as in the sample sheet...

HTML Code: 

Hmm, I tested the code before posting it here and, to the extent I understood your requirement, it does exactly what you said it needs to do.
I'm more than happy to help you troubleshoot this, but will need a bit more than "it isn't working as expected"
In the file you attached, the filename in column A has no extension (.txt), is that the issue perhaps? Step through the code line by line with F8 and check where it fails.
As for modifying the code you pasted, it certainly is possible.

Originally Posted by dOOb

Hmm, I tested the code before posting it here and, to the extent I understood your requirement, it does exactly what you said it needs to do.
I'm more than happy to help you troubleshoot this, but will need a bit more than "it isn't working as expected"
In the file you attached, the filename in column A has no extension (.txt), is that the issue perhaps? Step through the code line by line with F8 and check where it fails.
As for modifying the code you pasted, it certainly is possible.

Thank you for the prompt responses!!
I tried without the extension .txt and the code is running fine and doesn't throw any errors but it isn't fetching any data. When i tried with the extension .txt the code throws error at the line, Set myTxtFile = FSO.OpenTextFile(FilePath, ForReading) 'this reads the file to "memory"

Originally Posted by sarajun_88

I found this code on the web and this is working fine for one file at a time and displays the output in a msgbox.

Is it possible to modify the code to loop through a set of files in a folder and fetch the data as an output to an excel sheet as in the sample sheet...

HTML Code: 

dOOb,

In this code I see that the output is given in the form of msgbx.. how to get them written to an excel file..

Can u please help me on this? Really sorry about repeated requests..😑

What's the error description?
You definitely need the file extensions for this to work, so either full names (i.e. "filename.txt") in your worksheet, or change this line of code:

FilePath = Fld_obj & "\" & Filename

to

FilePath = Fld_obj & "\" & Filename & ".txt"

Try changing "ForReading" to "1" in the line that gives you the error.
I doubt it's this, but just in case you haven't got the right reference selected, it may be.

Also, this is working with Activesheet, so make sure the right one is active.

This works for me as you can see:
Capture.PNG

Let me know how you get on.

Originally Posted by dOOb

What's the error description?
You definitely need the file extensions for this to work, so either full names (i.e. "filename.txt") in your worksheet, or change this line of code:

FilePath = Fld_obj & "\" & Filename

to

FilePath = Fld_obj & "\" & Filename & ".txt"

Try changing "ForReading" to "1" in the line that gives you the error.
I doubt it's this, but just in case you haven't got the right reference selected, it may be.

Also, this is working with Activesheet, so make sure the right one is active.

This works for me as you can see:
Attachment 511917

Let me know how you get on.

its working perfectly for you... but don't know why its not the same for me. i made all the changes suggested by you yet its not working for me. I get an error on the same statement --- run-time error '53': file not found but all the files are in place.

Different method

Sub test()
    Dim myDir As String, fn, e, txt, a() As String, n As Long, dic As Object
    Dim myName As String, mtch As Object, m As Object
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = vbNullString Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    ReDim a(1 To 1000, 1 To 100): n = 1: a(n, 1) = "File name"
    With CreateObject("VBScript.RegExp")
        .Global = True
        fn = Dir(myDir & "\*.txt")
        Do While fn <> ""
            txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(myDir & fn).ReadAll
            n = n + 1: a(n, 1) = CreateObject("Scripting.FileSystemObject").GetBaseName(fn)
            .Pattern = "(.+?:)[\r\n]*((.*\r\n)+?)[\r\n]*(?=\-+)"
            Set mtch = .Execute(txt)
            For Each m In mtch
                myName = m.submatches(0)
                If Not dic.exists(myName) Then
                    dic(myName) = dic.Count + 2
                    If UBound(a, 2) < dic.Count + 1 Then
                        ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 100)
                    End If
                    a(1, dic(myName)) = myName
                End If
                .Pattern = "[\r\n]+$"
                a(n, dic(myName)) = .Replace(m.submatches(1), "")
            Next
            fn = Dir
        Loop
    End With
    Cells(1).Resize(n, dic.Count + 1) = a
End Sub

Originally Posted by jindon

Different method

Sub test()
    Dim myDir As String, fn, e, txt, a() As String, n As Long, dic As Object
    Dim myName As String, mtch As Object, m As Object
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = vbNullString Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    ReDim a(1 To 1000, 1 To 100): n = 1: a(n, 1) = "File name"
    With CreateObject("VBScript.RegExp")
        .Global = True
        fn = Dir(myDir & "\*.txt")
        Do While fn <> ""
            txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(myDir & fn).ReadAll
            n = n + 1: a(n, 1) = CreateObject("Scripting.FileSystemObject").GetBaseName(fn)
            .Pattern = "(.+?:)[\r\n]*((.*\r\n)+?)[\r\n]*(?=\-+)"
            Set mtch = .Execute(txt)
            For Each m In mtch
                myName = m.submatches(0)
                If Not dic.exists(myName) Then
                    dic(myName) = dic.Count + 2
                    If UBound(a, 2) < dic.Count + 1 Then
                        ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 100)
                    End If
                    a(1, dic(myName)) = myName
                End If
                .Pattern = "[\r\n]+$"
                a(n, dic(myName)) = .Replace(m.submatches(1), "")
            Next
            fn = Dir
        Loop
    End With
    Cells(1).Resize(n, dic.Count + 1) = a
End Sub

Thanks a lot jindon! It's working perfectly.
But my bad there are some portions where the data is like,
EGN: xxx
Hug: xxxxx

In this case I need the header as EGN and paste the data Xxx in the row.

As the code works only if there is ----- these sort of data's are not captured. Sorry for missing on this. Please help me on this...

Then I need to see few sample txt files.

Originally Posted by jindon

Then I need to see few sample txt files.

Please find the attached sample source and output files

Try this

Sub test()
    Dim myDir As String, fn, e, txt, a() As String, n As Long, dic As Object
    Dim myName As String, mtch As Object, m As Object, myVal As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = vbNullString Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    ReDim a(1 To 1000, 1 To 100): n = 1: a(n, 1) = "File name"
    With CreateObject("VBScript.RegExp")
        .Global = True
        fn = Dir(myDir & "\*.txt")
        Do While fn <> ""
            txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(myDir & fn).ReadAll
            n = n + 1: a(n, 1) = CreateObject("Scripting.FileSystemObject").GetBaseName(fn)
            .Pattern = "(.+?):[\r\n]*((.*\r\n)+?)[\r\n]*(?=\-+)|(.*?): (.+)"
            Set mtch = .Execute(txt)
            For Each m In mtch
                myName = m.submatches(0) & m.submatches(3)
                If Not dic.exists(myName) Then
                    dic(myName) = dic.Count + 2
                    If UBound(a, 2) < dic.Count + 1 Then
                        ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 100)
                    End If
                    a(1, dic(myName)) = myName
                End If
                .Pattern = "[\r\n]+$"
                a(n, dic(myName)) = .Replace(m.submatches(1), "") & .Replace(m.submatches(4), "")
            Next
            fn = Dir
        Loop
    End With
    Sheets(1).Cells(1).Resize(n, dic.Count + 1) = a
End Sub

Originally Posted by jindon

Try this

Sub test()
    Dim myDir As String, fn, e, txt, a() As String, n As Long, dic As Object
    Dim myName As String, mtch As Object, m As Object, myVal As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = vbNullString Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    ReDim a(1 To 1000, 1 To 100): n = 1: a(n, 1) = "File name"
    With CreateObject("VBScript.RegExp")
        .Global = True
        fn = Dir(myDir & "\*.txt")
        Do While fn <> ""
            txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(myDir & fn).ReadAll
            n = n + 1: a(n, 1) = CreateObject("Scripting.FileSystemObject").GetBaseName(fn)
            .Pattern = "(.+?):[\r\n]*((.*\r\n)+?)[\r\n]*(?=\-+)|(.*?): (.+)"
            Set mtch = .Execute(txt)
            For Each m In mtch
                myName = m.submatches(0) & m.submatches(3)
                If Not dic.exists(myName) Then
                    dic(myName) = dic.Count + 2
                    If UBound(a, 2) < dic.Count + 1 Then
                        ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 100)
                    End If
                    a(1, dic(myName)) = myName
                End If
                .Pattern = "[\r\n]+$"
                a(n, dic(myName)) = .Replace(m.submatches(1), "") & .Replace(m.submatches(4), "")
            Next
            fn = Dir
        Loop
    End With
    Sheets(1).Cells(1).Resize(n, dic.Count + 1) = a
End Sub

Thanks a lot jindon! It worked like a magic 😊