LinkBack URL
About LinkBacks
Dear all,
I have one text file. i need extract specific text to Excel file. please find text file and sample excel file attachments. kindly solve with code.
Thanking you all,
Best regards.
Extract specific text from Text file
Dear all,
I have one text file. i need extract specific text to Excel file. please find text file and sample excel file attachments. kindly solve with code.
Thanking you all,
Best regards.
Last edited by pvsvprasad; 08-20-2016 at 06:43 AM.
Hi.
This should do it. You'll just need to change the file path to the correct location.
(Also Column 2 the Concrete strength is 25 MPa not 30 MPa as shown in your example solution!)
Sub extract() Dim MyFile, srchname, searchstring, srchnum As String, Str As String, MyDir As String, Wb As Workbook Dim Rws As Long, Rng As Range Dim i, Mnum, Fenum, row, rownum As Integer row = 4 Set Wb = ThisWorkbook 'change the address to suit MyDir = "C:\temp\" MyFile = Dir(MyDir & "text file for extraction.txt") ChDir MyDir Application.ScreenUpdating = 1 Application.DisplayAlerts = 0 Workbooks.OpenText Filename:=MyFile, Origin:=xlMSDOS _ , StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _ , Space:=False, Other:=False, FieldInfo:=Array(1, 1), _ TrailingMinusNumbers:=True Do While ThisWorkbook.Worksheets("Sheet1").Range("AB" & row).Value <> "" srchname = ThisWorkbook.Worksheets("Sheet1").Range("AB" & row).Value srchnum = ThisWorkbook.Worksheets("Sheet1").Range("AC" & row).Value If srchname = "B E A M" Then searchstring = srchname & " N O." & WorksheetFunction.Rept(" ", 8 - Len(srchnum)) & srchnum Else searchstring = srchname & " N O." & WorksheetFunction.Rept(" ", 7 - Len(srchnum)) & srchnum End If With Worksheets(1) Cells.Find(What:=searchstring, After:=ActiveCell, LookIn:= _ xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _ xlNext, MatchCase:=False, SearchFormat:=False).Activate rownum = ActiveCell.row Mnum = WorksheetFunction.Find("M", Range("A" & rownum + 2).Value) Fenum = WorksheetFunction.Find("Fe", Range("A" & rownum + 2).Value) cMPA = Mid(Range("A" & rownum + 2).Value, Mnum + 1, 2) sMPA = Mid(Range("A" & rownum + 2).Value, Fenum + 2, 3) ThisWorkbook.Worksheets("Sheet1").Range("AD" & row) = cMPA ThisWorkbook.Worksheets("Sheet1").Range("AE" & row) = sMPA row = row + 1 End With Loop MsgBox ("Finished") End Sub
Happy with my advice? Click on the * reputation button below
Dear sir,Originally Posted by Crooza
Thank you for your kind reply and point out sample file mistake. is this possible make a code by choosing file location dialog box pop (Instead of "C:\temp\")?
Thanking you sir,
Best regards.
Last edited by pvsvprasad; 08-20-2016 at 06:45 AM.
This version should open a dialogue box for you to select the file
Sub extract() Dim MyFile, srchname, searchstring, srchnum As String, Str As String, MyDir As String, Wb As Workbook Dim Rws As Long, Rng As Range Dim i, Mnum, Fenum, row, rownum As Integer row = 4 ' Open the file dialog Set MyFile = Application.FileDialog(msoFileDialogOpen) With MyFile .Title = "Choose File" .AllowMultiSelect = False If .Show <> -1 Then Exit Sub End If fileselected = .SelectedItems(1) End With Set Wb = ThisWorkbook Application.ScreenUpdating = 1 Application.DisplayAlerts = 0 Workbooks.OpenText Filename:=fileselected, Origin:=xlMSDOS _ , StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _ , Space:=False, Other:=False, FieldInfo:=Array(1, 1), _ TrailingMinusNumbers:=True Do While ThisWorkbook.Worksheets("Sheet1").Range("AB" & row).Value <> "" srchname = ThisWorkbook.Worksheets("Sheet1").Range("AB" & row).Value srchnum = ThisWorkbook.Worksheets("Sheet1").Range("AC" & row).Value If srchname = "B E A M" Then searchstring = srchname & " N O." & WorksheetFunction.Rept(" ", 8 - Len(srchnum)) & srchnum Else searchstring = srchname & " N O." & WorksheetFunction.Rept(" ", 7 - Len(srchnum)) & srchnum End If With Worksheets(1) Cells.Find(What:=searchstring, After:=ActiveCell, LookIn:= _ xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _ xlNext, MatchCase:=False, SearchFormat:=False).Activate rownum = ActiveCell.row Mnum = WorksheetFunction.Find("M", Range("A" & rownum + 2).Value) Fenum = WorksheetFunction.Find("Fe", Range("A" & rownum + 2).Value) cMPA = Mid(Range("A" & rownum + 2).Value, Mnum + 1, 2) sMPA = Mid(Range("A" & rownum + 2).Value, Fenum + 2, 3) ThisWorkbook.Worksheets("Sheet1").Range("AD" & row) = cMPA ThisWorkbook.Worksheets("Sheet1").Range("AE" & row) = sMPA row = row + 1 End With Loop MsgBox ("Finished") End Sub
Dear sir,
sorry for confusion, i am wrongly assumed as #4 and #5 codes is produced by one person.i apologies for this wrong assumption.
after using your #4 code entire text file is pasted to new excel sheet. kindly check the code.
thanking you sir,
Best regards.
You could try:
AlfApplication.Dialogs(xlDialogOpen).Show ("*.txt")
Dear sir,You could try:
AlfApplication.Dialogs(xlDialogOpen).Show ("*.txt")
thank you for your code.
after using your code entire text file is pasted to new excel sheet. kindly check the code.
which location i have to paste above quoted code?
thanking you sir,
Best regards.
You asked for
and that is what you got. If this was not what you wanted you got a post from crooza that hopefully is what you wish for and not what you asked for.a code by choosing file location dialog box pop (Instead of "C:\temp\")?
Alf
Yes it extracts the text file as a workbook in order to get the data you require. What exactly isn't working?
This will close the text file afterwards if that is what the issue is
Sub extract() Dim MyFile, srchname, searchstring, srchnum As String, Str As String, MyDir As String, Wb As Workbook Dim Rws As Long, Rng As Range Dim i, Mnum, Fenum, row, rownum As Integer row = 4 ' Open the file dialog Set MyFile = Application.FileDialog(msoFileDialogOpen) With MyFile .Title = "Choose File" .AllowMultiSelect = False If .Show <> -1 Then Exit Sub End If fileselected = .SelectedItems(1) End With Set Wb = ThisWorkbook Application.ScreenUpdating = 0 Application.DisplayAlerts = 0 Workbooks.OpenText Filename:=fileselected, Origin:=xlMSDOS _ , StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _ , Space:=False, Other:=False, FieldInfo:=Array(1, 1), _ TrailingMinusNumbers:=True Do While ThisWorkbook.Worksheets("Sheet1").Range("AB" & row).Value <> "" srchname = ThisWorkbook.Worksheets("Sheet1").Range("AB" & row).Value srchnum = ThisWorkbook.Worksheets("Sheet1").Range("AC" & row).Value If srchname = "B E A M" Then searchstring = srchname & " N O." & WorksheetFunction.Rept(" ", 8 - Len(srchnum)) & srchnum Else searchstring = srchname & " N O." & WorksheetFunction.Rept(" ", 7 - Len(srchnum)) & srchnum End If With Worksheets(1) Cells.Find(What:=searchstring, After:=ActiveCell, LookIn:= _ xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _ xlNext, MatchCase:=False, SearchFormat:=False).Activate rownum = ActiveCell.row Mnum = WorksheetFunction.Find("M", Range("A" & rownum + 2).Value) Fenum = WorksheetFunction.Find("Fe", Range("A" & rownum + 2).Value) cMPA = Mid(Range("A" & rownum + 2).Value, Mnum + 1, 2) sMPA = Mid(Range("A" & rownum + 2).Value, Fenum + 2, 3) ThisWorkbook.Worksheets("Sheet1").Range("AD" & row) = cMPA ThisWorkbook.Worksheets("Sheet1").Range("AE" & row) = sMPA row = row + 1 End With Loop ActiveWorkbook.Close True MsgBox ("Finished") End Sub
Re: Extract specific text from Text file
Dear sir, thank you for preparing.
issue is Your code is producing error.kindly find the sample files of text and Excel files. please correct the code.
Thank you,
Best regards.
Last edited by pvsvprasad; 08-21-2016 at 01:43 PM.
Please find InputText file. please solve this bug.
OK A couple of things
1. You've changed the format of your file. You've moved your input data around into different columns. For this example I put your data BACK into your original columns AB and AC
2. You're now asking for different data to be searched for. In your original file you had data that matched your search file so there was no need to check if there wasn't a match, now you're seeking to find only a subset which means I need to code around that for the instances where there is no match
3. Your latest example has 'new' column data with three columns of returned data - what s the 2000 and the 230? are you seeking to collect that data too.
The attached file represents your original file (and its format) but I've added your latest input data list. It extracts only what it can find and skips the rest. It presumably will work multiple times if your search data is in different text files. Just run it again and select the next text file to search in.
Yes sir, i am apologies for sending wrong moved column data.your prepared code for columns, i.e AD and AE columns are correct.
yes sir, i need columns for 2000 and 230 also required. but for those columns i have used one old code.so please combine your latest code with my old code with minor corrections.
in my old code having some bugs. there is developing some repeating rows and not maintained output rows as ascending order with respect to "Z' Column(i.e, 1,2,3,4,5 etc)
my old code for X to AC column as below:
kindly make suitable correction to form exact code or make a New code by your way of style by selecting .anl text file format.please find of Exact format of sample Output excel file.Sub test() Dim fn As String, txt As String, n As Long, m As Object, mtch As Object, sm As Object, a() fn = Application.GetOpenFilename("TextFiles,*.anl") If fn = "False" Then Exit Sub txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll With CreateObject("VBScript.RegExp") .Global = True: .MultiLine = True .Pattern = "^ *=+(\r\n)([^=]+\r\n)+" Set mtch = .Execute(txt) ReDim a(1 To mtch.Count) .Pattern = "^ +(.*?) +N O\. +(\d+)(.*\r\n){4}.*?: +(\d+\.\d+).*?: +(\d+\.\d+).*?X +(\d+\.\d+).*" For Each m In mtch If .test(m) Then n = n + 1: Set sm = .Execute(m)(0).submatches a(n) = Array(n, sm(0), sm(1), sm(3), sm(4), sm(4)) End If Next End With If n > 0 Then ReDim Preserve a(1 To n) [a2].Resize(n, 6).Value = Application.Index(a, 0, 0) End If End Sub
thank you for your kind help.
,
with best regards.
Last edited by pvsvprasad; 08-22-2016 at 02:37 AM.
Sub test() Dim fn As String, txt As String, n As Long, m As Object, mtch As Object, sm As Object, a() fn = Application.GetOpenFilename("TextFiles,*.txt") If fn = "False" Then Exit Sub txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll With CreateObject("VBScript.RegExp") .Global = True: .MultiLine = True .Pattern = "^ *=+(\r\n)([^=]+\r\n)+" Set mtch = .Execute(txt) ReDim a(1 To mtch.Count) .Pattern = "^ +(.*?) +N O\. +(\d+)(.*\r\n){2} +M(\d+) +Fe(\d+)" For Each m In mtch If .test(m) Then n = n + 1: Set sm = .Execute(m)(0).submatches a(n) = Array(sm(0), sm(1), sm(3), sm(4)) End If Next End With If n > 0 Then ReDim Preserve a(1 To n) [ab2].Resize(n, 4).Value = Application.Index(a, 0, 0) End If End Sub
Re: Extract specific text from Text file
Dear sir, thank you for kind reply. you code is nice. minor bugs are arrived. please fix these bugs.
1)AB column is starting from Y column. i.e Y to AE columns
2)Please make out put data as a Ascending order with basis of of Z column. kindly find the sample excel file.
3)And some of Rows are printed duplicates with respect to Z column members.
please find exact form of Output excel file.
kindly make these corrections, rest of all your code is good.
Thanking you sir,
Best regards.
Last edited by pvsvprasad; 08-22-2016 at 03:31 AM.
please find Exact format of Excel format file and Raw data text file.
Thanking you,
Best regards.
You must learn the meaning of "BUGS".
I've just worked on your first post. I haven't even looked at the rest of the posts.
Sub test() Dim fn As String, txt As String, n As Long, m As Object, mtch As Object, sm As Object, dic As Object fn = Application.GetOpenFilename("TextFiles,*.anl") If fn = "False" Then Exit Sub Set dic = CreateObject("Scripting.Dictionary") dic.CompareMode = 1 txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll With CreateObject("VBScript.RegExp") .Global = True: .MultiLine = True .Pattern = "^ *=+(\r\n)([^=]+\r\n)+" Set mtch = .Execute(txt) ReDim a(1 To mtch.Count) .Pattern = "^ +(.*?) +N O\. +(\d+)(.*\r\n){2} +M(\d+) +Fe(\d+)(.*\r\n){2}.*?: +(\d+\.\d+).*?: +(\d+\.\d+).*?X +(\d+\.\d+).*" For Each m In mtch If .test(m) Then Set sm = .Execute(m)(0).submatches If Not dic.exists(sm(0) & sm(1)) Then dic(sm(0) & sm(1)) = Array(sm(0), sm(1), sm(6), sm(7), sm(8), sm(3), sm(4)) End If Next End With If dic.Count Then [y2].Resize(dic.Count, 7).Value = Application.Index(dic.items, 0, 0) End If End Sub
Dear sir,
i have expressed extreme apologies for using of that word. sorry for poor technical knowledge.i will edit my posts.
now your code is perfect.thank you for preparing.please make small correction. i.e out put should be producing as ascending order with respect to Z column order.example based upon Z should produced from lowest value to highest value(1,2,3,4, etc).
please find sample output excel file.
thanking you,
Best regards.
Last edited by pvsvprasad; 08-22-2016 at 03:33 AM.
change
toIf dic.Count Then [y2].Resize(dic.Count, 7).Value = Application.Index(dic.items, 0, 0) End If
If dic.Count Then With [y2].Resize(dic.Count, 7) .Value = Application.Index(dic.items, 0, 0) .Sort .Cells(1, 2), 1 End With End If
Dear sir,change
to
If dic.Count Then With [y2].Resize(dic.Count, 7) .Value = Application.Index(dic.items, 0, 0) .Sort .Cells(1, 2), 1 End With End If
your code is really marvelous. its working as a charm.(your provided sample file link #21 is not working. showing download error as "Invalid Attachment specified. If you followed a valid link")
Thank you very much for solving my problem sir.
Best regards.
Deleted wrong thread.......................
Last edited by jindon; 08-22-2016 at 03:47 AM.
I can't open a ZIP file but it looks like JINDON has this well and truly covered now. You should ensure you add to his reputation as he/she has done a lot o work to sort this out for you.
Yes sir, sure.
you also doing well. thank you for your effort.
Best regards.
There are currently 1 users browsing this thread. (0 members and 1 guests)
Posting Permissions
Register To Reply
Bookmarks