Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Old January 5th 05, 06:57 PM
Willie T
 
Posts: n/a
Default Read Text File into Excel Using VBA

Hi All,

I'm a new VBA programmer. I know how to pull an entire text file
into an Excel Spreadsheet, but I only want specific information from
the text file not the entire text file.

What I have is about 25 text files stored in a folder, let's say
C:\test.

Each file is named by a property address as follows:
209 MAIN ST.txt
213 MAIN ST.txt
111 ELM ST.txt
2356 WOOD AVE.txt

On the 11th row of each file is as follows:
Property Address:209 MAIN ST
On the 31st row of each file is as follows:
Total Value:30500

What I would like to do is read each file located in the "C:\test
folder and write a record (row) into a single Excel Spreadsheet for
each property. I would like the Excel Spreadsheet to look as follows
once completed. Note the 1st row below is a header row that needs to
be generated by the code.

Property Address Total Value
209 MAIN ST 30500
213 MAIN ST 60700
111 ELM ST 20400
2356 WOOD AVE 20900

Can I read a header list (in a spreadsheet, text file, or hard coded in
the code) which I would prefer the spreadsheet or text file method,
write the header row in A1 then B1. Next read the 25 text files and
search based on the header info written above (Property Address & Total
Value) and write the appropriate to the single spreadsheet. The 11th
row of the First text file value written in cell A2, then read the 31st
row of the First text file write the value in cell B2, then loop to the
Second text file and values from The 11th row of the Second text file
value written in cell A3, then read the 31st row of the Second text
file write the value in cell B3, so on and so forth until the last text
file is read and the last record is written.
I know this is elementary to most, but I'm a beginner programmer and
sure could use the help...
Can any one help?

Thanks in advance.

Willie T


  #2   Report Post  
Old January 5th 05, 07:00 PM
Willie T
 
Posts: n/a
Default

Ok, I have a Routine that will read a user defined folder via an
InputBox and get a list of all the files in that folder.

Next I pass that info to a Routine that Reads the Full Text files into
individual Excel spreadsheets, so I've made some progress.

My problems left to resolve:
1. I want to read into one single spreadsheet not 25 (i.e. 25 text
files into a single spreadsheet)
2. I want 1 header line in the one spreadsheet
3. I want only select info out of each text file not the entire text
file.

Can I read the 11th line in each of the text file and import ONLY the
text behind the semicolon?
For example, the 11th line in each file is as follows:
Property Address:209 MAIN ST
I only want to import "209 MAIN ST" from the 11th line in each text
file and place the first entry in A2 of the Excel Spreadsheet, then
read the next file and place that Property Address in Cell A3 until all
text files are read.

Can anyone help or direct me to a group that can.

Code is listed below. Keep in mind that since the code is snippets, it
still need some clean up.

Thanks in advance.

Willie T

Dim MyFileSystemObject As Object 'fs
Dim MyFolderObject As Object 'f
Dim MyFileObject As Object 'f1
Dim MyFileCollection As Object 'fc
Sub LoopThroughInputFiles()
Dim RoutineStartSecondCount As Long
Dim ThisFileFinishSecondCount As Long
Dim AverageSecondsPerFile As Long
Dim StringToDebugPrint As String

RoutineStartSecondCount = Int(Timer) 'int of seconds elapsed since
midnight

FolderContainingRawFiles = InputBox("Enter Name, c/w Path, of Folder
Containing Raw Files")

FileCounter = 0 'initialise

'Dim MyFileSystemObject As Object 'fs
'Dim MyFolderObject As Object 'f
'Dim MyFileObject As Object 'f1
'Dim MyFileCollection As Object 'fc

Set MyFileSystemObject = CreateObject("Scripting.FileSystemObject")
'MyFileSystemObject is a filesystemobject
Set MyFolderObject =
MyFileSystemObject.GetFolder(FolderContainingRawFi les) 'MyFolderObject
is the folder object

Set MyFileCollection = MyFolderObject.Files 'fc is the collection of
file objects in folder object f

For Each MyFileObject In MyFileCollection
FileToWorkWith = MyFileObject.Name
'Now call function/sub to work with file...
'FunctionToOpenAndWorkWithFile
ReadFullTextFile


FileCounter = FileCounter + 1
ThisFileFinishSecondCount = Int(Timer)
AverageSecondsPerFile = (ThisFileFinishSecondCount -
RoutineStartSecondCount) / FileCounter
StringToDebugPrint = FileCounter & " files (of about "
StringToDebugPrint = StringToDebugPrint &
MyFileCollection.Count
StringToDebugPrint = StringToDebugPrint & ") done so far;
time remaining "
StringToDebugPrint = StringToDebugPrint &
Format((AverageSecondsPerFile * (MyFileCollection.Count - FileCounter)
/ 60), "0.0")
StringToDebugPrint = StringToDebugPrint & " minutes"
StringToDebugPrint = StringToDebugPrint & " (average " &
Int(AverageSecondsPerFile)
StringToDebugPrint = StringToDebugPrint & " seconds/file)"
Debug.Print StringToDebugPrint

Next
Debug.Print "File Addition Finished (at last!) " & Date & ", " &
Time
End Sub


Sub ReadFullTextFile()

Dim oExcel As Object
Dim oBook As Object
Dim osheet As Object

Dim filename As String

Set oExcel = CreateObject("Excel.Application")

' Open text file
'filename = "c:\MAIN-ST-205.txt"
'Set oBook = oExcel.Workbooks.Open(filename)
Set oBook = oExcel.Workbooks.Open(MyFileObject)
Set oBook = oExcel.ActiveWorkbook

oBook.Sheets(1).Activate
Set osheet = oBook.Sheets(1)

'Set osheet = oBook.ActiveSheet
' Make Excel visible
oExcel.Visible = True
oExcel.UserControl = True

' save as excel workbook
'filename2 = "c:\MAIN-ST-205.xls"
filename2 = (MyFileObject) & ".xls"
oBook.SaveAs filename2, 1

' ***** At this point I would like to run a macro, however they are
'not available in the macro window or within this code.
Set oExcel = Nothing
Set oBook = Nothing

'End
End Sub

  #3   Report Post  
Old January 6th 05, 12:59 AM
Dave Peterson
 
Posts: n/a
Default

First, you wrote semicolon, but typed a colon (. I'm guessing your sample is
correct.

And if you have a key value in your text file, you could use that key instead of
counting records. (Counting records is fine if there's no other way--but if
someone edits a single file and deletes/inserts a line, then the code will break
down pretty fast. I'd believe the key (as long as it's unique???).)

And since you're running this from excel, you don't need to create another
instance of excel. You can just have another workbook open in that same
instance.

And you can read a text file using "Open xxx For Input As ###" and read each
line looking for what you want.

And there's lots of ways to get the list of .txt files from a single folder. I
used a different one from yours.

If this seems to make sense, then how about this:

Option Explicit
Sub testme()

Dim myFiles() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim wkbk As Workbook
Dim wks As Worksheet

'change to point at the folder to check
myPath = "c:\my documents\excel"
If Right(myPath, 1) < "\" Then
myPath = myPath & "\"
End If

myFile = Dir(myPath & "*.txt")
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

'get the list of files
fCtr = 0
Do While myFile < ""
fCtr = fCtr + 1
ReDim Preserve myFiles(1 To fCtr)
myFiles(fCtr) = myFile
myFile = Dir()
Loop

If fCtr 0 Then
Set wks = Workbooks.Add(1).Worksheets(1)
wks.Range("a1").Resize(1, 3).Value _
= Array("Property Address", "Total Value", "FileName")

For fCtr = LBound(myFiles) To UBound(myFiles)
Call DoTheWork(myPath & myFiles(fCtr), wks)
Next fCtr

wks.UsedRange.Columns.AutoFit
End If

End Sub
Sub DoTheWork(myFileName As String, wks As Worksheet)

Dim myNumber As Long
Dim myLine As String
Dim FileNum As Long
Dim oRow As Long
Dim FoundAddr As Boolean
Dim FoundTot As Boolean
Dim Str1 As String
Dim Str2 As String

Str1 = LCase("Property Address:")
Str2 = LCase("Total Value:")

With wks
oRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With

FoundAddr = False
FoundTot = False

FileNum = FreeFile
Close FileNum
Open myFileName For Input As FileNum
wks.Cells(oRow, "C").Value = myFileName
Do While Not EOF(FileNum)
Line Input #FileNum, myLine
If LCase(Left(myLine, Len(Str1))) = Str1 Then
wks.Cells(oRow, "A").Value = Trim(Mid(myLine, Len(Str1) + 1))
FoundAddr = True
ElseIf LCase(Left(myLine, Len(Str2))) = Str2 Then
wks.Cells(oRow, "B").Value = Trim(Mid(myLine, Len(Str2) + 1))
FoundTot = True
Exit Do 'no need to contine reading the file
End If
Loop

If FoundAddr = False Then
wks.Cells(oRow, "A").Value = "**Error**"
End If
If FoundTot = False Then
wks.Cells(oRow, "B").Value = "**Error**"
End If

Close FileNum

End Sub


===
But I did depend on the order of the input not changing--address comes before
total.


Willie T wrote:

Ok, I have a Routine that will read a user defined folder via an
InputBox and get a list of all the files in that folder.

Next I pass that info to a Routine that Reads the Full Text files into
individual Excel spreadsheets, so I've made some progress.

My problems left to resolve:
1. I want to read into one single spreadsheet not 25 (i.e. 25 text
files into a single spreadsheet)
2. I want 1 header line in the one spreadsheet
3. I want only select info out of each text file not the entire text
file.

Can I read the 11th line in each of the text file and import ONLY the
text behind the semicolon?
For example, the 11th line in each file is as follows:
Property Address:209 MAIN ST
I only want to import "209 MAIN ST" from the 11th line in each text
file and place the first entry in A2 of the Excel Spreadsheet, then
read the next file and place that Property Address in Cell A3 until all
text files are read.

Can anyone help or direct me to a group that can.

Code is listed below. Keep in mind that since the code is snippets, it
still need some clean up.

Thanks in advance.

Willie T

Dim MyFileSystemObject As Object 'fs
Dim MyFolderObject As Object 'f
Dim MyFileObject As Object 'f1
Dim MyFileCollection As Object 'fc
Sub LoopThroughInputFiles()
Dim RoutineStartSecondCount As Long
Dim ThisFileFinishSecondCount As Long
Dim AverageSecondsPerFile As Long
Dim StringToDebugPrint As String

RoutineStartSecondCount = Int(Timer) 'int of seconds elapsed since
midnight

FolderContainingRawFiles = InputBox("Enter Name, c/w Path, of Folder
Containing Raw Files")

FileCounter = 0 'initialise

'Dim MyFileSystemObject As Object 'fs
'Dim MyFolderObject As Object 'f
'Dim MyFileObject As Object 'f1
'Dim MyFileCollection As Object 'fc

Set MyFileSystemObject = CreateObject("Scripting.FileSystemObject")
'MyFileSystemObject is a filesystemobject
Set MyFolderObject =
MyFileSystemObject.GetFolder(FolderContainingRawFi les) 'MyFolderObject
is the folder object

Set MyFileCollection = MyFolderObject.Files 'fc is the collection of
file objects in folder object f

For Each MyFileObject In MyFileCollection
FileToWorkWith = MyFileObject.Name
'Now call function/sub to work with file...
'FunctionToOpenAndWorkWithFile
ReadFullTextFile

FileCounter = FileCounter + 1
ThisFileFinishSecondCount = Int(Timer)
AverageSecondsPerFile = (ThisFileFinishSecondCount -
RoutineStartSecondCount) / FileCounter
StringToDebugPrint = FileCounter & " files (of about "
StringToDebugPrint = StringToDebugPrint &
MyFileCollection.Count
StringToDebugPrint = StringToDebugPrint & ") done so far;
time remaining "
StringToDebugPrint = StringToDebugPrint &
Format((AverageSecondsPerFile * (MyFileCollection.Count - FileCounter)
/ 60), "0.0")
StringToDebugPrint = StringToDebugPrint & " minutes"
StringToDebugPrint = StringToDebugPrint & " (average " &
Int(AverageSecondsPerFile)
StringToDebugPrint = StringToDebugPrint & " seconds/file)"
Debug.Print StringToDebugPrint

Next
Debug.Print "File Addition Finished (at last!) " & Date & ", " &
Time
End Sub

Sub ReadFullTextFile()

Dim oExcel As Object
Dim oBook As Object
Dim osheet As Object

Dim filename As String

Set oExcel = CreateObject("Excel.Application")

' Open text file
'filename = "c:\MAIN-ST-205.txt"
'Set oBook = oExcel.Workbooks.Open(filename)
Set oBook = oExcel.Workbooks.Open(MyFileObject)
Set oBook = oExcel.ActiveWorkbook

oBook.Sheets(1).Activate
Set osheet = oBook.Sheets(1)

'Set osheet = oBook.ActiveSheet
' Make Excel visible
oExcel.Visible = True
oExcel.UserControl = True

' save as excel workbook
'filename2 = "c:\MAIN-ST-205.xls"
filename2 = (MyFileObject) & ".xls"
oBook.SaveAs filename2, 1

' ***** At this point I would like to run a macro, however they are
'not available in the macro window or within this code.
Set oExcel = Nothing
Set oBook = Nothing

'End
End Sub


--

Dave Peterson
  #4   Report Post  
Old January 6th 05, 04:55 PM
Willie T
 
Posts: n/a
Default

Dave,

Thanks a million. It is a colon, my bad. Your code makes more sence
and runs fine, but I'm returning **Error** in both cases. Again, I new
to VBA and programming but i can step thru your code, see how it work,
and follow it fairly well. Below is a sample of one of the text files
that I running your code against. It the 14th line down for Str1 and
the 34th line down for Str2. Can you help? Thanks again for your help
in advance.

Report on Parcel xx-xx-2-000-022.000 00Courthouse Retrieval System -
Jefferson
County, AL
Report on Parcel :xx-xx-2-000-022.000 00Generated :1/4/2005


General Information

LastName FirstName MidNane
FirstName MidNane
xxxx CHERRY AVE
BIRMINGHAM , AL 35214Parcel ID:xx-xx-2-000-022.000 00
Alt-Parcel ID:152420002200
Subdivision
Property Address:205 MAIN ST
BIRMINGHAM, AL 35213-2914
Telephone)-
Special Int:
Map Sort::
Plat Book:0000
Subdv Block:
Parcel:0
SSD1:000
Ward:05
Land C Map:
Acct No:
Page:0000
Lot:
District:05
SSD2:


Land Value:2900
Improvement Value:5200
Total Value:8100
Assessed Value:1620

  #5   Report Post  
Old January 7th 05, 01:05 AM
Dave Peterson
 
Posts: n/a
Default

I pasted your sample data into a text file and saved it.

I got this out:

Property Address Total Value FileName
**Error** **Error** c:\my documents\excel\README.TXT
205 MAIN ST 8100 c:\my documents\excel\Edit3.txt
**Error** **Error** c:\my documents\excel\test.txt
**Error** **Error** c:\my documents\excel\spacedelim.txt


Just guesses.

You did change the folder name:
myPath = "c:\my documents\excel"

Do you have any lines with leading spaces?

If yes, you could clean them up in your favorite text editor (yech!) or just do
it in code:

Do While Not EOF(FileNum)
Line Input #FileNum, myLine
If LCase(Left(Trim(myLine), Len(Str1))) = Str1 Then '<---
wks.Cells(oRow, "A").Value = Trim(Mid(myLine, Len(Str1) + 1))
FoundAddr = True
ElseIf LCase(Left(Trim(myLine), Len(Str2))) = Str2 Then '<---
wks.Cells(oRow, "B").Value = Trim(Mid(myLine, Len(Str2) + 1))
FoundTot = True
Exit Do 'no need to contine reading the file
End If
Loop

(notice the addition of Trim() in 2 spots.)

(I'm guessing that there's something else in that text file that's difficult to
see/notice.)




Willie T wrote:

Dave,

Thanks a million. It is a colon, my bad. Your code makes more sence
and runs fine, but I'm returning **Error** in both cases. Again, I new
to VBA and programming but i can step thru your code, see how it work,
and follow it fairly well. Below is a sample of one of the text files
that I running your code against. It the 14th line down for Str1 and
the 34th line down for Str2. Can you help? Thanks again for your help
in advance.

Report on Parcel xx-xx-2-000-022.000 00Courthouse Retrieval System -
Jefferson
County, AL
Report on Parcel :xx-xx-2-000-022.000 00Generated :1/4/2005

General Information

LastName FirstName MidNane
FirstName MidNane
xxxx CHERRY AVE
BIRMINGHAM , AL 35214Parcel ID:xx-xx-2-000-022.000 00
Alt-Parcel ID:152420002200
Subdivision
Property Address:205 MAIN ST
BIRMINGHAM, AL 35213-2914
Telephone)-
Special Int:
Map Sort::
Plat Book:0000
Subdv Block:
Parcel:0
SSD1:000
Ward:05
Land C Map:
Acct No:
Page:0000
Lot:
District:05
SSD2:

Land Value:2900
Improvement Value:5200
Total Value:8100
Assessed Value:1620


--

Dave Peterson


  #6   Report Post  
Old January 7th 05, 01:15 AM
Willie T
 
Posts: n/a
Default

Dave,

I know the problem, but not the solution...

The leading spaces are causing me a problem in the text files. I also
took out the Lower Case option; although, I'm not sure if that was part
of my problem or not. As you can see below, I padded Str1 with the
leading spaces and it worked fine, but Str2 still returned **Error**.


'Str1 = LCase("Property Address:")
'Str2 = LCase("Total Value:")

Str1 = (" Property Address:")
Str2 = ("Total Value:")

Also note in my Do While Loop I also took out the LCase option.

Do While Not EOF(FileNum)
Line Input #FileNum, myLine
'If LCase(Left(myLine, Len(Str1))) = Str1 Then
If Left(myLine, Len(Str1)) = Str1 Then
wks.Cells(oRow, "A").Value = Trim(Mid(myLine, Len(Str1) +
1))
FoundAddr = True
'ElseIf LCase(Left(myLine, Len(Str2))) = Str2 Then
ElseIf (Left(myLine, Len(Str2))) = Str2 Then
wks.Cells(oRow, "B").Value = Trim(Mid(myLine, Len(Str2) +
1))
FoundTot = True
Exit Do 'no need to contine reading the file
End If
Loop

Is there a way to strip out or not consider the leading blank spaces.

Thanks again for your help. This application is going to cut my old
manual processing time down from about 5 days to less than 1 day.
Thanks

Willie T

  #7   Report Post  
Old January 7th 05, 02:02 AM
Dave Peterson
 
Posts: n/a
Default

We crossed in the ether.

See my other post (if you haven't already).

(I'd put back the lcase() stuff. Just seems a little safer to me--or less to do
when you get a file that's been manually edited.)

Willie T wrote:

Dave,

I know the problem, but not the solution...

The leading spaces are causing me a problem in the text files. I also
took out the Lower Case option; although, I'm not sure if that was part
of my problem or not. As you can see below, I padded Str1 with the
leading spaces and it worked fine, but Str2 still returned **Error**.

'Str1 = LCase("Property Address:")
'Str2 = LCase("Total Value:")

Str1 = (" Property Address:")
Str2 = ("Total Value:")

Also note in my Do While Loop I also took out the LCase option.

Do While Not EOF(FileNum)
Line Input #FileNum, myLine
'If LCase(Left(myLine, Len(Str1))) = Str1 Then
If Left(myLine, Len(Str1)) = Str1 Then
wks.Cells(oRow, "A").Value = Trim(Mid(myLine, Len(Str1) +
1))
FoundAddr = True
'ElseIf LCase(Left(myLine, Len(Str2))) = Str2 Then
ElseIf (Left(myLine, Len(Str2))) = Str2 Then
wks.Cells(oRow, "B").Value = Trim(Mid(myLine, Len(Str2) +
1))
FoundTot = True
Exit Do 'no need to contine reading the file
End If
Loop

Is there a way to strip out or not consider the leading blank spaces.

Thanks again for your help. This application is going to cut my old
manual processing time down from about 5 days to less than 1 day.
Thanks

Willie T


--

Dave Peterson
  #8   Report Post  
Old January 7th 05, 03:49 AM
Willie T
 
Posts: n/a
Default

Dude,

I'm slow close now. I've added alot including some input boxes that
will be used later on in the application. It is picking up the
property address and the Total Value but not the other items that i
have added. Below is my code and the results:

Sub testme()

Dim myFiles() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim wkbk As Workbook
Dim wks As Worksheet
Dim defaultproject As String
Dim ProjectName As String

'Key in your Project Name
defaultproject = "2005 Brookside Property - ALL"
ProjectName = InputBox("Enter Project Name", "Project Name:",
defaultproject)

'Key in your City or Town
city = "Brookside"
CityName = InputBox("Enter City or Town Name", "City or Town
Name:", city)

'change to point at the folder to check
'myPath = "c:\test"
myPath = "\\Hpoffice\my documents\Projects\HMGP\Brookside\2005
Brookside Project Application\CRS Full Reports"
myPath = InputBox("Enter Path of Folder Containing Text Files",
"Text Files Folder:", myPath)


If Right(myPath, 1) < "\" Then
myPath = myPath & "\"
End If

myFile = Dir(myPath & "*.txt")
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

'get the list of files
fCtr = 0
Do While myFile < ""
fCtr = fCtr + 1
ReDim Preserve myFiles(1 To fCtr)
myFiles(fCtr) = myFile
myFile = Dir()
Loop

If fCtr 0 Then
'Set wks = Workbooks.Add(1).Worksheets(1)
Set wks = Workbooks.Add(1).Worksheets(1)

' wks.Range("a1").Resize(1, 3).Value _
' = Array("Property Address", "City", "FileName")
wks.Range("a1").Resize(1, 6).Value _
= Array("Property Address", "City", "Land Value", "Imp
Value", "Tot Value", "FileName")

For fCtr = LBound(myFiles) To UBound(myFiles)
Call DoTheWork(myPath & myFiles(fCtr), wks)
Next fCtr

wks.UsedRange.Columns.AutoFit
End If

End Sub
Sub DoTheWork(myFileName As String, wks As Worksheet)

Dim myNumber As Long
Dim myLine As String
Dim FileNum As Long
Dim oRow As Long

Dim FoundAddr As Boolean
Dim FoundCity As Boolean
Dim FoundLandValue As Boolean
Dim FoundImpValue As Boolean
Dim FoundTotValue As Boolean

Dim StrAddr As String
Dim StrCity As String
Dim StrLandValue As String
Dim StrImpValue As String
Dim StrTotValue As String

'StrAddr = LCase(" Property Address:")
StrAddr = LCase("Property Address:")
StrCity = LCase("| TAX DISTRICT:") 'City
StrLandValue = LCase("Land Value:") 'Land Value
StrImpValue = LCase("Improvement Value:") 'Structures Value
StrTotValue = LCase("Total Value:") 'Land Value + Structures Value

With wks
oRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With

FoundAddr = False
FoundCity = False
FoundLandValue = False
FoundImpValue = False
FoundTotValue = False

FileNum = FreeFile
Close FileNum
Open myFileName For Input As FileNum
' wks.Cells(oRow, "C").Value = myFileName
wks.Cells(oRow, "F").Value = myFileName

Do While Not EOF(FileNum)
Line Input #FileNum, myLine
'If LCase(Left(myLine, Len(Str1))) = Str1 Then
If LCase(Left(Trim(myLine), Len(StrAddr))) = StrAddr Then
wks.Cells(oRow, "A").Value = Trim(Mid(myLine, Len(StrAddr) +
1))
FoundAddr = True
ElseIf LCase(Left(Trim(myLine), Len(StrCity))) = StrCity Then
wks.Cells(oRow, "B").Value = Trim(Mid(myLine, Len(StrCity) +
1))
FoundCity = True
Exit Do 'no need to contine reading the file
ElseIf LCase(Left(Trim(myLine), Len(StrLandValue))) =
StrLandValue Then
wks.Cells(oRow, "C").Value = Trim(Mid(myLine,
Len(StrLandValue) + 1))
FoundLandValue = True
Exit Do 'no need to contine reading the file
ElseIf LCase(Left(Trim(myLine), Len(StrImpValue))) =
StrImpValue Then
wks.Cells(oRow, "D").Value = Trim(Mid(myLine,
Len(StrImpValue) + 1))
FoundImpValue = True
Exit Do 'no need to contine reading the file
ElseIf LCase(Left(Trim(myLine), Len(StrTotValue))) =
StrTotValue Then
wks.Cells(oRow, "E").Value = Trim(Mid(myLine,
Len(StrTotValue) + 1))
FoundTotValue = True
Exit Do 'no need to contine reading the file
End If
Loop

If FoundAddr = False Then
wks.Cells(oRow, "A").Value = "**Error**"
End If
If FoundCity = False Then
wks.Cells(oRow, "B").Value = "**Error**"
End If
If FoundLandValue = False Then
wks.Cells(oRow, "C").Value = "**Error**"
End If
If FoundImpValue = False Then
wks.Cells(oRow, "D").Value = "**Error**"
End If
If FoundTotValue = False Then
wks.Cells(oRow, "E").Value = "**Error**"
End If

Close FileNum

End Sub


Results:
Property Address City Land Value Imp Value Tot Value
Property Address:264 BIVENS BROOKSID RD **Error** Land
Value:4400 **Error** **Error**
Property Address:292 BIVENS BROOKSID RD **Error** Land
Value:14000 **Error** **Error**
Property Address:204 CARDIFF ST **Error** Land
Value:12600 **Error** **Error**
Property Address:324 CARDIFF ST **Error** Land
Value:7100 **Error** **Error**
Property Address:445 CARDIFF ST **Error** Land
Value:9200 **Error** **Error**
Property Address:428 GRAHAM DR **Error** Land
Value:14200 **Error** **Error**
Property Address:110 MAIN ST **Error** Land
Value:5300 **Error** **Error**
Property Address:200 MAIN ST **Error** Land
Value:6700 **Error** **Error**
Property Address:201 MAIN ST **Error** Land
Value:3900 **Error** **Error**
Property Address:205 MAIN ST **Error** Land
Value:2900 **Error** **Error**
Property Address:209 MAIN ST **Error** Land
Value:1500 **Error** **Error**
Property Address:117 MARKET ST **Error** Land
Value:7600 **Error** **Error**
Property Address:141 MARKET ST **Error** Land
Value:6800 **Error** **Error**
Property Address:207 MARKET ST **Error** Land
Value:5400 **Error** **Error**
Property Address:140 MIMOSA ST **Error** Land
Value:17000 **Error** **Error**
Property Address:111 PRICE ST **Error** Land
Value:3100 **Error** **Error**
Property Address:132 PRICE ST **Error** Land
Value:3900 **Error** **Error**
Property Address:136 PRICE ST **Error** Land
Value:3500 **Error** **Error**
Property Address:140 PRICE ST **Error** Land
Value:2600 **Error** **Error**
Property Address:144 PRICE ST **Error** Land
Value:3500 **Error** **Error**
Property Address:145 PRICE ST **Error** Land
Value:3700 **Error** **Error**
Property Address:216 PRICE ST **Error** Land
Value:4500 **Error** **Error**
Property Address:220 PRICE ST **Error** Land
Value:6100 **Error** **Error**
Property Address:119 VALLEY DR **Error** Land
Value:16100 **Error** **Error**
Property Address:130 VALLEY DR **Error** Land
Value:13200 **Error** **Error**
Property Address:154 VALLEY DR **Error** Land
Value:11900 **Error** **Error**


Here is a sample text file:

Report on Parcel 15-24-2-000-021.000 00Courthouse Retrieval System -
Jefferson
County, AL
Report on Parcel :15-24-2-000-021.000 00Generated :1/4/2005


General Information

SPRUELL THERON C

1756 CHERRY AVE
BIRMINGHAM , AL 35214Parcel ID:15-24-2-000-021.000 00
Alt-Parcel ID:152420002100
Subdivision
Property Address:201 MAIN ST
BIRMINGHAM, AL 35213-2914
Telephone)-
Special Int:
Map Sort::
Plat Book:0000
Subdv Block:
Parcel:0
SSD1:000
Ward:05
Land C Map:
Acct No:
Page:0000
Lot:
District:05
SSD2:


Land Value:3900
Improvement Value:0
Total Value:3900
Assessed Value:780
City Tax:
County Tax:
Total Tax:
Last Sale Date:
Last Sale Amount:0
Book/Page:/
Document No:
Exemption Amount:0
Exemption Reason:
Dimensions:36S X 415S IRR
Acreage:0.33
Square Feet:
Geo Code:-86.755083 : 33.506186
Census Tract:108.01
Census Block:1
Gas Source:PUBLIC
Electric Source:PUBLIC
Water Source:PUBLIC
Sewer Source:INDIVIDUAL
Description:P O B 290 FT S N OF N E INTER OF MAIN ST
& PRICE
ST TH N 36 FT S ALG MAIN ST TH E 300 FT D 350 FT S TO
CENTER
LINE OF 5 | TAX DISTRICT: BROOKSIDE
Property Type:COMMERCIAL
Land Use:910 VACANT AND UNUSED LAND
Improvement Type:
Zoning Code:I3
Owner Type:
Road Type:PAVED
Topography:LEVEL
District Trend:


Land Data For Parcel
Land TypeLand SizeLand AmountLand Use
REG. LOT: SQFT144053850910


Building Information - No Building Data Available for Parcel:
15-24-2-000-021.000 00



Extra Features - No Extra Feature Data Available for Parcel:
15-24-2-000-021.000
00



Sales & Deed History


Sales DataDeed Data
No Sales Data Available for Parcel...
Owner:Book:1446Date:04/13/77
Page:0943




Trust Deed Information - No Trust Deed Data Available for Parcel:
15-24-2-000-021.000 00
Information Deemed Reliable, but Not Guaranteed

  #9   Report Post  
Old January 7th 05, 04:31 AM
Dave Peterson
 
Posts: n/a
Default

There were a bunch of "exit do"'s that said to leave the loop as soon as that
record was found.

If you know that one of those keys is always last, you can exit after you find
that. It should make processing a little faster--but with small files, it
probably won't be noticeable.

And instead of using several boolean values, I just prepopulated the row with
**Error**'s. Then the real data will overwrite it if found. (makes it a little
simpler. (I didn't think of it until I logged off yesterday.)

Option Explicit
Sub testme()

Dim myFiles() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim wkbk As Workbook
Dim wks As Worksheet
Dim defaultproject As String
Dim ProjectName As String
Dim City As String
Dim CityName As String

'Key in your Project Name
defaultproject = "2005 Brookside Property - ALL"
ProjectName = InputBox("Enter Project Name", "Project Name:", defaultproject)

'Key in your City or Town
City = "Brookside"
CityName = InputBox("Enter City or Town Name", "City or Town Name:", City)

'change to point at the folder to check
'myPath = "c:\test"
myPath = "\\Hpoffice\my documents\Projects\HMGP\Brookside\" & _
"2005 Brookside Project Application\CRS Full Reports"
myPath = InputBox("Enter Path of Folder Containing Text Files", _
"Text Files Folder:", myPath)


If Right(myPath, 1) < "\" Then
myPath = myPath & "\"
End If

myFile = Dir(myPath & "*.txt")
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

'get the list of files
fCtr = 0
Do While myFile < ""
fCtr = fCtr + 1
ReDim Preserve myFiles(1 To fCtr)
myFiles(fCtr) = myFile
myFile = Dir()
Loop

If fCtr 0 Then
Set wks = Workbooks.Add(1).Worksheets(1)
wks.Range("a1").Resize(1, 6).Value _
= Array("Property Address", "City", "Land Value", "Imp Value", _
"Tot Value", "FileName")

For fCtr = LBound(myFiles) To UBound(myFiles)
Call DoTheWork(myPath & myFiles(fCtr), wks)
Next fCtr

wks.UsedRange.Columns.AutoFit
End If

End Sub
Sub DoTheWork(myFileName As String, wks As Worksheet)

Dim myNumber As Long
Dim myLine As String
Dim FileNum As Long
Dim oRow As Long

Dim StrAddr As String
Dim StrCity As String
Dim StrLandValue As String
Dim StrImpValue As String
Dim StrTotValue As String

StrAddr = LCase("Property Address:")
StrCity = LCase("| TAX DISTRICT:") 'City
StrLandValue = LCase("Land Value:") 'Land Value
StrImpValue = LCase("Improvement Value:") 'Structures Value
StrTotValue = LCase("Total Value:") 'Land Value + Structures Value

With wks
oRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With

wks.Cells(oRow, "A").Resize(1, 5).Value = "**Error**"

FileNum = FreeFile
Close FileNum
Open myFileName For Input As FileNum
wks.Cells(oRow, "F").Value = myFileName

Do While Not EOF(FileNum)
Line Input #FileNum, myLine
If LCase(Left(Trim(myLine), Len(StrAddr))) = StrAddr Then
wks.Cells(oRow, "A").Value = Trim(Mid(myLine, Len(StrAddr) + 1))
ElseIf LCase(Left(Trim(myLine), Len(StrCity))) = StrCity Then
wks.Cells(oRow, "B").Value = Trim(Mid(myLine, Len(StrCity) + 1))
Exit Do '<---only one get out now in any of these tests!
ElseIf LCase(Left(Trim(myLine), Len(StrLandValue))) = StrLandValue Then
wks.Cells(oRow, "C").Value = Trim(Mid(myLine, Len(StrLandValue) + 1))
ElseIf LCase(Left(Trim(myLine), Len(StrImpValue))) = StrImpValue Then
wks.Cells(oRow, "D").Value = Trim(Mid(myLine, Len(StrImpValue) + 1))
ElseIf LCase(Left(Trim(myLine), Len(StrTotValue))) = StrTotValue Then
wks.Cells(oRow, "E").Value = Trim(Mid(myLine, Len(StrTotValue) + 1))
End If
Loop

Close FileNum

End Sub

===
As an aside, to get the folder,

If you're using xl2002+, you can read about:
Application.FileDialog
in VBA's help.

If before, then Jim Rech has a BrowseForFolder routine at:
http://www.oaltd.co.uk/MVP/Default.htm
(look for BrowseForFolder)

Or John Walkenbach's:
http://j-walk.com/ss/excel/tips/tip29.htm





Willie T wrote:

Dude,

I'm slow close now. I've added alot including some input boxes that
will be used later on in the application. It is picking up the
property address and the Total Value but not the other items that i
have added. Below is my code and the results:

Sub testme()

Dim myFiles() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim wkbk As Workbook
Dim wks As Worksheet
Dim defaultproject As String
Dim ProjectName As String

'Key in your Project Name
defaultproject = "2005 Brookside Property - ALL"
ProjectName = InputBox("Enter Project Name", "Project Name:",
defaultproject)

'Key in your City or Town
city = "Brookside"
CityName = InputBox("Enter City or Town Name", "City or Town
Name:", city)

'change to point at the folder to check
'myPath = "c:\test"
myPath = "\\Hpoffice\my documents\Projects\HMGP\Brookside\2005
Brookside Project Application\CRS Full Reports"
myPath = InputBox("Enter Path of Folder Containing Text Files",
"Text Files Folder:", myPath)

If Right(myPath, 1) < "\" Then
myPath = myPath & "\"
End If

myFile = Dir(myPath & "*.txt")
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

'get the list of files
fCtr = 0
Do While myFile < ""
fCtr = fCtr + 1
ReDim Preserve myFiles(1 To fCtr)
myFiles(fCtr) = myFile
myFile = Dir()
Loop

If fCtr 0 Then
'Set wks = Workbooks.Add(1).Worksheets(1)
Set wks = Workbooks.Add(1).Worksheets(1)

' wks.Range("a1").Resize(1, 3).Value _
' = Array("Property Address", "City", "FileName")
wks.Range("a1").Resize(1, 6).Value _
= Array("Property Address", "City", "Land Value", "Imp
Value", "Tot Value", "FileName")

For fCtr = LBound(myFiles) To UBound(myFiles)
Call DoTheWork(myPath & myFiles(fCtr), wks)
Next fCtr

wks.UsedRange.Columns.AutoFit
End If

End Sub
Sub DoTheWork(myFileName As String, wks As Worksheet)

Dim myNumber As Long
Dim myLine As String
Dim FileNum As Long
Dim oRow As Long

Dim FoundAddr As Boolean
Dim FoundCity As Boolean
Dim FoundLandValue As Boolean
Dim FoundImpValue As Boolean
Dim FoundTotValue As Boolean

Dim StrAddr As String
Dim StrCity As String
Dim StrLandValue As String
Dim StrImpValue As String
Dim StrTotValue As String

'StrAddr = LCase(" Property Address:")
StrAddr = LCase("Property Address:")
StrCity = LCase("| TAX DISTRICT:") 'City
StrLandValue = LCase("Land Value:") 'Land Value
StrImpValue = LCase("Improvement Value:") 'Structures Value
StrTotValue = LCase("Total Value:") 'Land Value + Structures Value

With wks
oRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With

FoundAddr = False
FoundCity = False
FoundLandValue = False
FoundImpValue = False
FoundTotValue = False

FileNum = FreeFile
Close FileNum
Open myFileName For Input As FileNum
' wks.Cells(oRow, "C").Value = myFileName
wks.Cells(oRow, "F").Value = myFileName

Do While Not EOF(FileNum)
Line Input #FileNum, myLine
'If LCase(Left(myLine, Len(Str1))) = Str1 Then
If LCase(Left(Trim(myLine), Len(StrAddr))) = StrAddr Then
wks.Cells(oRow, "A").Value = Trim(Mid(myLine, Len(StrAddr) +
1))
FoundAddr = True
ElseIf LCase(Left(Trim(myLine), Len(StrCity))) = StrCity Then
wks.Cells(oRow, "B").Value = Trim(Mid(myLine, Len(StrCity) +
1))
FoundCity = True
Exit Do 'no need to contine reading the file
ElseIf LCase(Left(Trim(myLine), Len(StrLandValue))) =
StrLandValue Then
wks.Cells(oRow, "C").Value = Trim(Mid(myLine,
Len(StrLandValue) + 1))
FoundLandValue = True
Exit Do 'no need to contine reading the file
ElseIf LCase(Left(Trim(myLine), Len(StrImpValue))) =
StrImpValue Then
wks.Cells(oRow, "D").Value = Trim(Mid(myLine,
Len(StrImpValue) + 1))
FoundImpValue = True
Exit Do 'no need to contine reading the file
ElseIf LCase(Left(Trim(myLine), Len(StrTotValue))) =
StrTotValue Then
wks.Cells(oRow, "E").Value = Trim(Mid(myLine,
Len(StrTotValue) + 1))
FoundTotValue = True
Exit Do 'no need to contine reading the file
End If
Loop

If FoundAddr = False Then
wks.Cells(oRow, "A").Value = "**Error**"
End If
If FoundCity = False Then
wks.Cells(oRow, "B").Value = "**Error**"
End If
If FoundLandValue = False Then
wks.Cells(oRow, "C").Value = "**Error**"
End If
If FoundImpValue = False Then
wks.Cells(oRow, "D").Value = "**Error**"
End If
If FoundTotValue = False Then
wks.Cells(oRow, "E").Value = "**Error**"
End If

Close FileNum

End Sub

Results:
Property Address City Land Value Imp Value Tot Value
Property Address:264 BIVENS BROOKSID RD **Error** Land
Value:4400 **Error** **Error**
Property Address:292 BIVENS BROOKSID RD **Error** Land
Value:14000 **Error** **Error**
Property Address:204 CARDIFF ST **Error** Land
Value:12600 **Error** **Error**
Property Address:324 CARDIFF ST **Error** Land
Value:7100 **Error** **Error**
Property Address:445 CARDIFF ST **Error** Land
Value:9200 **Error** **Error**
Property Address:428 GRAHAM DR **Error** Land
Value:14200 **Error** **Error**
Property Address:110 MAIN ST **Error** Land
Value:5300 **Error** **Error**
Property Address:200 MAIN ST **Error** Land
Value:6700 **Error** **Error**
Property Address:201 MAIN ST **Error** Land
Value:3900 **Error** **Error**
Property Address:205 MAIN ST **Error** Land
Value:2900 **Error** **Error**
Property Address:209 MAIN ST **Error** Land
Value:1500 **Error** **Error**
Property Address:117 MARKET ST **Error** Land
Value:7600 **Error** **Error**
Property Address:141 MARKET ST **Error** Land
Value:6800 **Error** **Error**
Property Address:207 MARKET ST **Error** Land
Value:5400 **Error** **Error**
Property Address:140 MIMOSA ST **Error** Land
Value:17000 **Error** **Error**
Property Address:111 PRICE ST **Error** Land
Value:3100 **Error** **Error**
Property Address:132 PRICE ST **Error** Land
Value:3900 **Error** **Error**
Property Address:136 PRICE ST **Error** Land
Value:3500 **Error** **Error**
Property Address:140 PRICE ST **Error** Land
Value:2600 **Error** **Error**
Property Address:144 PRICE ST **Error** Land
Value:3500 **Error** **Error**
Property Address:145 PRICE ST **Error** Land
Value:3700 **Error** **Error**
Property Address:216 PRICE ST **Error** Land
Value:4500 **Error** **Error**
Property Address:220 PRICE ST **Error** Land
Value:6100 **Error** **Error**
Property Address:119 VALLEY DR **Error** Land
Value:16100 **Error** **Error**
Property Address:130 VALLEY DR **Error** Land
Value:13200 **Error** **Error**
Property Address:154 VALLEY DR **Error** Land
Value:11900 **Error** **Error**

Here is a sample text file:

Report on Parcel 15-24-2-000-021.000 00Courthouse Retrieval System -
Jefferson
County, AL
Report on Parcel :15-24-2-000-021.000 00Generated :1/4/2005

General Information

SPRUELL THERON C

1756 CHERRY AVE
BIRMINGHAM , AL 35214Parcel ID:15-24-2-000-021.000 00
Alt-Parcel ID:152420002100
Subdivision
Property Address:201 MAIN ST
BIRMINGHAM, AL 35213-2914
Telephone)-
Special Int:
Map Sort::
Plat Book:0000
Subdv Block:
Parcel:0
SSD1:000
Ward:05
Land C Map:
Acct No:
Page:0000
Lot:
District:05
SSD2:

Land Value:3900
Improvement Value:0
Total Value:3900
Assessed Value:780
City Tax:
County Tax:
Total Tax:
Last Sale Date:
Last Sale Amount:0
Book/Page:/
Document No:
Exemption Amount:0
Exemption Reason:
Dimensions:36S X 415S IRR
Acreage:0.33
Square Feet:
Geo Code:-86.755083 : 33.506186
Census Tract:108.01
Census Block:1
Gas Source:PUBLIC
Electric Source:PUBLIC
Water Source:PUBLIC
Sewer Source:INDIVIDUAL
Description:P O B 290 FT S N OF N E INTER OF MAIN ST
& PRICE
ST TH N 36 FT S ALG MAIN ST TH E 300 FT D 350 FT S TO
CENTER
LINE OF 5 | TAX DISTRICT: BROOKSIDE
Property Type:COMMERCIAL
Land Use:910 VACANT AND UNUSED LAND
Improvement Type:
Zoning Code:I3
Owner Type:
Road Type:PAVED
Topography:LEVEL
District Trend:

Land Data For Parcel
Land TypeLand SizeLand AmountLand Use
REG. LOT: SQFT144053850910

Building Information - No Building Data Available for Parcel:
15-24-2-000-021.000 00

Extra Features - No Extra Feature Data Available for Parcel:
15-24-2-000-021.000
00

Sales & Deed History

Sales DataDeed Data
No Sales Data Available for Parcel...
Owner:Book:1446Date:04/13/77
Page:0943

Trust Deed Information - No Trust Deed Data Available for Parcel:
15-24-2-000-021.000 00
Information Deemed Reliable, but Not Guaranteed


--

Dave Peterson
  #10   Report Post  
Old January 7th 05, 04:47 AM
Dave Peterson
 
Posts: n/a
Default

I see you have another thread going elsewhere.

I'll bow out.

<<snipped


Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules

Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On


Similar Threads
Thread Thread Starter Forum Replies Last Post
Excel 2003 FAILS, but Excel 2000 SUCCEEDS ??? Richard Excel Discussion (Misc queries) 1 January 5th 05 09:36 AM
Make a text file from Excel workbook Ramana Murthy Excel Discussion (Misc queries) 7 January 3rd 05 06:37 PM
Excel 2000 file when opened in Excel 2003 generates errors? Doug Excel Discussion (Misc queries) 13 December 25th 04 11:20 PM
numbers and text in Excel to read as text keeping the leading zer. Ralph Excel Discussion (Misc queries) 2 December 10th 04 08:05 PM
Using Jet to read excel file returns blank for last cell - sometim Ron Excel Discussion (Misc queries) 1 December 9th 04 09:21 AM


All times are GMT +1. The time now is 07:05 AM.

Powered by vBulletin® Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.
Copyright 2004-2019 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Copyright © 2017