PDA

View Full Version : Solved: Another Query question



DanOfEarth
07-07-2010, 07:33 AM
O.K. Because of my shameless neediness, I have donateth a small tith to VBA Express via Paypal. And larger ones shall come.:beerchug:

And this time, I blatenly just can't think of the "loop" or code, although it's simple.

This below query is working great, thanks to GTO. It finds the persons' last name, goes three cells down, tests to see if there is a "phone number". If not, in place of the phone number there is always text saying "More Info". It then copies the phone number if there is one.

However there are multiple instances of the last name on the page. I just need to check each instance until I get a positive with the red code, then leave the loop. I'm assuming I do this with a Do Until statement somewhere in here, or rather I'm thinking the .find method might have a nuance. This should get me to the finish line. This particular method is odd to Google on.

Dim rngFound As Range, rngToTest As Range
Dim sFirstAddress As String

' We've already imported the data we need onto the Import2 sheet. We need to search it for
' the above LastName we are looking for
With Sheets("Import2").Range("A139:A200")
Set rngFound = .Find( _
What:=LastName, _
Lookat:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True)

' This confirms that we found the LastName successfully
If Not rngFound Is Nothing Then
Set rngToTest = rngFound

' This offsets down three cells and captures the phone number
MyPhoneNumber = rngToTest.Offset(3, 0).Value
If MyPhoneNumber <> "More Info" Then
ActiveCell.Offset(0, 7).Formula = MyPhoneNumber
Else
End If
'Note the address of the first found cell so we know where we started.
sFirstAddress = rngFound.Address

'I have no earthly idea what the next FindNext and loop does....oh well
Set rngFound = .FindNext(After:=rngFound)
Do Until rngFound.Address = sFirstAddress
Set rngToTest = Union(rngToTest, rngFound)
Set rngFound = .FindNext(After:=rngFound)


Loop

End If
End With


When it's done, anybody who wants this, it's a cool crawler that checks a list of addresses against www.yellowpages.com (http://www.yellowpages.com) and automatically strips their phone number and pastes it. I'll rearrange it for a generic use and supply the entire code. It's just this last hurdle of check checking each instance, not just the first one like it's doing now. There will be multiple people in the household, but only one them has a listed phone. I'm trying to capture just one number and move on.

Bob Phillips
07-07-2010, 02:36 PM
Can you post a workbook?

DanOfEarth
07-07-2010, 03:48 PM
Yes indeed. I cleaned up the book from the mryiad of other buttons and code. In the Lead Sheet with the list of addresses, notice I put a gap every 15th row or so so that it stops....sort of an error handler.

Anyway, just click any address "#" on column C, then hit the button. It starts the query on that row.

The problem is this. In a household in yellow pages, it will have possibly three members of the family listed, back -to- back, but only one of the names/instances will have a phone number under it. I just need to capture just one, then bug out of the sub.

Currently, it searches until it finds the first one, checks if the number is there, then bugs out without trying the other one or two instances. I commented the code pretty tightly.

I know it's gotta possibly be an extra Do-Until-Loop....dunno. I'm already nested 5 deep in loops...I'm losing track.

You'll see there's an extra sheet with different search results I've saved (side by side) to analyze different scenarios. Otherwise, all of the data is typically just saved in one long column on Sheet "Import2"

Bob Phillips
07-08-2010, 01:09 AM
I think this may be what you want but I was unable to fully test it because I don't know a zip code that will return a phone n umber in #2 or #3 but not #1 (and I wasn't going to debug each item, it is far too slow).



Sub QueryWhitePages()
Dim rngFound As Range, rngToTest As Range
Dim sFirstAddress As String
Dim ItemFound As Boolean

With Application
.Calculation = xlCalculationManual
End With

'=========Using known addresses, this subroutine uses a reverse-search on whitepages.com to find the
'=========people's phone number. It does the query, thren pastes the results to Sheets(Import2), and we
'=========then manipulate the data on it.

Const MyUrl2 As String = "http://www.whitepages.com/5116/search/ReverseAddress?street="

'Sheets("Import2").Visible = True

'======Have user activate the first row-position in Column C (Address number)to start the querying
'======and set query parameters based on that.......

Do Until IsEmpty(ActiveCell)

With Sheets("Leads")
Set Address2 = ActiveCell.Offset(0, 2)
Set Zip2 = ActiveCell.Offset(0, -1)
Set LastName = ActiveCell.Offset(0, 11)

End With

With Sheets("Import2").QueryTables.Add(Connection:= _
"URL;" & MyUrl2 & Address2 & "&zip=" & Zip2 _
, Destination:=Sheets("Import2").Range("Import2!$A$1"))
.Name = "5116/search/ReverseAddress?street="
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With

'======Now....using the pasted data, sort out the addresses that are obviously not on there======


If Range("ResultsWhitePages") = "Please modify your search." Then
ActiveCell.Offset(0, 7).Formula = "Z - N/A"
ElseIf Left(Range("ResultsWhitePages"), 1) = 1 And Range("ResultsSecondLine") = "Find Neighbors" Then
ActiveCell.Offset(0, 7).Formula = "Z - N/A"
ElseIf Left(Range("ResultsWhitePages"), 1) = 2 And Range("ResultsPhone1") = "More Info" And Range("ResultsPhone2") = "More Info" Then
ActiveCell.Offset(0, 7).Formula = "Z - N/A"
ElseIf Left(Range("ResultsWhitePages"), 1) = 3 And Range("ResultsPhone1") = "More Info" And Range("ResultsPhone2") = "More Info" And Range("ResultsPhone3") = "More Info" Then
ActiveCell.Offset(0, 7).Formula = "Z - N/A"

Else

'=========================================START PARSER SECTION==============================

'=========STILL NEEDS WORK!! DOES NOT CHECK MULTIPLE INSTANCES OF POSITIVE DATA==============

' We've already imported the data we need onto the Import2 sheet. We need to search it for
' the above LastName we are looking for
With Sheets("Import2").Range("A139:A200")

Set rngFound = .Find( _
What:=LastName, _
Lookat:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True)

' This confirms that we found the LastName successfully
If Not rngFound Is Nothing Then

ItemFound = False

'Note the address of the first found cell so we know where we started.
sFirstAddress = rngFound.Address

Do

' We know that the phone number, if it exists, is always three lines below the Last Name
' on data sheet. If it's not there, it always says "More Info".
' This offsets down three cells and captures the phone number
MyPhoneNumber = rngFound.Offset(3, 0).Value
If MyPhoneNumber <> "More Info" Then

ActiveCell.Offset(0, 7).Formula = MyPhoneNumber
ItemFound = True
Else

Set rngFound = .FindNext(After:=rngFound)
End If
Loop Until ItemFound Or rngFound.Address = sFirstAddress
End If
End With
'==================================END PARSER SECTION==============================

End If

ActiveCell.Offset(1, 0).Select
Loop

'Sheets("Import2").Visible = False

With Application
.Calculation = xlCalculationAutomatic
End With
End Sub

DanOfEarth
07-08-2010, 07:49 AM
That's brilliant! Thank you!

Just reading it is tells me it should work. Oh...I forgot to tell you, if you hit the blue square in any line of the address, it will do a manual search next to that address to check out the results. That's how I was debugging it.

I'll look for an address like that. I think I zapped a secion out of the list that had several in it.

Without testing yet though, are you sure the "Do" on the Do-Until loop shouldn't be actually higher up, in the line below?


With Sheets("Import2").Range("A139:A200")

Do

Set rngFound = .Find( _
What:=LastName, _
Lookat:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True)

Bob Phillips
07-08-2010, 08:56 AM
Without testing yet though, are you sure the "Do" on the Do-Until loop shouldn't be actually higher up, in the line below?


With Sheets("Import2").Range("A139:A200")

Do

Set rngFound = .Find( _
What:=LastName, _
Lookat:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True)


Absolutely sure. If you move it up to there, you will execute the FindNext loop before you have found anything to start with.

DanOfEarth
07-08-2010, 09:11 AM
Ahhhhsooo..

Once more shameful Grasshopper foolishly doubts the masters wisdom....:jsmile:

DanOfEarth
07-08-2010, 09:25 PM
You are a genious. It's working like a charm!

This thing is fantastic.

When you get it going, it's like watching phone numbers magically appear out of thin air.:wizard:

Couldn't live without these forums!

If anybody wants a web crawler for the yellowpages that will scrub entire phone lists or names for phone numbers, let me know.

Bob Phillips
07-09-2010, 12:27 AM
Put in it an article or the Knowledge Base for the archives.