Import Data from txt file

L

Little Penny

Everyday I receive 50 to 100 text files containing a few lines of
information. I save all the files to a folder on my desktop. I'm
looking for a excel macro that will extract specific information from
each file then delete it. The files look as follows.

ICI_D243gdj_000056_VP5637X5

Indexs: 5
Text01: 8
IDHXC: 756352
RunName: VP5637X5

I want to extracted the "Indexs" and the "RunName" and import to
excel spreadsheet to look like this.

VP5637X5 5


I want to do this for each txt file in the designated folder and have
the results imported to the next row in my open the spreadsheet.

The data I received is not delimited but the format is always the
same. With the exception of the "Indexs" could be up to 7 digits.

Example:

ICI_D243gdj_000056_XW5637X6

Indexs: 7245691
Text01: 8
IDHXC: 756352
RunName: XW5637X6

VP5637X5 5
XW5637X6 7245691


Thanks for your Help

Larry
 
J

Joel

Sub Gettext()

Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const MyPath = "C:\temp\"
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0

Const TxtDirectory = "C:\temp\test\"

Dim Runname As String
Dim Index As String
Set fsread = CreateObject("Scripting.FileSystemObject")

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
If (LastRow = 1) And IsEmpty(Cells(LastRow, "A")) Then
RowCount = 1
Else
RowCount = LastRow + 1
End If
first = True
Do While (True)

If first = True Then
ReadFileName = Dir(TxtDirectory & "*.txt")
first = False
Else
ReadFileName = Dir()
End If

If Len(ReadFileName) = 0 Then Exit Do
'open files
ReadPathName = TxtDirectory + ReadFileName
Set fread = fsread.GetFile(ReadPathName)
Set tsread = fread.OpenAsTextStream(ForReading, TristateUseDefault)

Runname = ""
Index = ""
Do While tsread.atendofstream = False

InputLine = tsread.ReadLine


If (InStr(InputLine, "Indexs:") > 0) Then

Index = Trim(Mid(InputLine, InStr(InputLine, ":") + 1))
End If
If (InStr(InputLine, "RunName:") > 0) Then

Runname = Trim(Mid(InputLine, InStr(InputLine, ":") + 1))
End If

If (Len(Runname) > 0) And (Len(Index) > 0) Then
Exit Do
End If
Loop
tsread.Close

Cells(RowCount, "A") = Runname
Cells(RowCount, "B") = Index
RowCount = RowCount + 1

Loop

End Sub
 
L

Little Penny

Thanks for your speedy reply Joel


Macro works great but it only imports the "Indexs" value and not the
"Runname" value into to my spread sheet. Is there something specific I
should be doing?

It looks like this:

A B
1
2
18
2
1
6
2
3
1

Colum A is empty...

It should look like this..

A B
XW84725 1
GH56729 2
BF57437 18
KK84672 2
VZ25265 1
HD90689 6
BB47472 2
LB35353 3
MN7373 1



Thanks
 
J

Joel

try adding value to these to lines

from:
Cells(RowCount, "A") = Runname
Cells(RowCount, "B") = Index
to:
Cells(RowCount, "A").value = Runname
Cells(RowCount, "B").value = Index

if this doesn't work I added a msgbox in code below to try to isolate where
the problem is. I took you sample data and the code work correctly by simply
pasting you data into a txtt file


Sub Gettext()

Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const MyPath = "C:\temp\"
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0

Const TxtDirectory = "C:\temp\test\"

Dim Runname As String
Dim Index As String
Set fsread = CreateObject("Scripting.FileSystemObject")

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
If (LastRow = 1) And IsEmpty(Cells(LastRow, "A")) Then
RowCount = 1
Else
RowCount = LastRow + 1
End If
first = True
Do While (True)

If first = True Then
ReadFileName = Dir(TxtDirectory & "*.txt")
first = False
Else
ReadFileName = Dir()
End If

If Len(ReadFileName) = 0 Then Exit Do
'open files
ReadPathName = TxtDirectory + ReadFileName
Set fread = fsread.GetFile(ReadPathName)
Set tsread = fread.OpenAsTextStream(ForReading, TristateUseDefault)

Runname = ""
Index = ""
Do While tsread.atendofstream = False

InputLine = tsread.ReadLine


If (InStr(InputLine, "Indexs:") > 0) Then

Index = Trim(Mid(InputLine, InStr(InputLine, ":") + 1))
End If
If (InStr(InputLine, "RunName:") > 0) Then

Runname = Trim(Mid(InputLine, InStr(InputLine, ":") + 1))
msgbox(InputLine)
msgbox(Runname)
End If

If (Len(Runname) > 0) And (Len(Index) > 0) Then
Exit Do
End If
Loop
tsread.Close

Cells(RowCount, "A") = Runname
Cells(RowCount, "B") = Index
RowCount = RowCount + 1

Loop

End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top