Import Data from txt file

[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

 

[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

 

[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

 

[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