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