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

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" wrote:

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

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



On Aug 13, 10:16 am, Joel wrote:
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" wrote:
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- Hide quoted text -

- Show quoted text -

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



"Little Penny" wrote:

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



On Aug 13, 10:16 am, Joel wrote:
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" wrote:
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- Hide quoted text -

- Show quoted text -