Try these changes. I'm only getting the firwst page of results. You
may get multiple people for each search request.

Sub YellowPageSearch()
'This project includes references to "Microsoft Internet Controls" and
'"Microsoft HTML Object Library"

'Variable declarations
Dim appIE As New InternetExplorer
Dim myURL As String
Dim myDoc As HTMLDocument
Dim strSearch As String
Dim newHour As Variant
Dim newMinute As Variant
Dim newSecond As Variant
Dim waitTime As Variant
Dim cn As Range
Dim cf As Range
Dim cc As Range
Dim cs As Range
'Dim cz As Range

'On Error GoTo errHandler

'Set starting range (first cell of data)
Set cn = Sheets("Sheet1").Range("b2")
Set cf = Sheets("Sheet1").Range("c2")
Set cc = Sheets("Sheet1").Range("d2")
Set cs = Sheets("Sheet1").Range("e2")
'Set cz = Sheets("Sheet1").Range("f2")

'Set starting URL and search string
myURL = "http://www.yellowpages.com/findaperson"

'loop through list of data
Do While cn.Value < vbNullString

'Make IE navigate to the URL and make browser visible
appIE.Navigate myURL
appIE.Visible = True

'Wait for the page to load
Do While appIE.Busy Or _
appIE.readyState < READYSTATE_COMPLETE

DoEvents
Loop

'Set IE document into object

Set myDoc = appIE.document


'Enter search string on form
myDoc.forms(0).qn.Value = cn.Value
myDoc.forms(0).qf.Value = cf.Value
myDoc.forms(0).qc.Value = cc.Value
myDoc.forms(0).qs.Value = cs.Value
'myDoc.forms(0).qz.Value = cz.Value

'Submit form
myDoc.forms(0).submit

'Wait for the page to load
Do While appIE.Busy Or _
appIE.readyState < READYSTATE_COMPLETE

DoEvents
Loop

Set myDoc = appIE.document

'uncomment line for debugging
'Call dump(myDoc)

Found_Results = False
RowCount = 0

For Each itm In myDoc.all

If itm.tagName = "TABLE" And _
itm.className = "resultTable" Then

Found_Results = True
DIV_Count = 0
RowCount = RowCount + 1
End If
If Found_Results = True Then
If itm.tagName = "DIV" Then
DIV_Count = DIV_Count + 1

With Sheets("Sheet2")
Select Case DIV_Count
Case 1
FullName = itm.innerText
Range("A" & RowCount) = FullName
Case 3
Address = itm.innerText
Range("B" & RowCount) = Address
Case 4
PhoneNumber = itm.innerText
Range("C" & RowCount) = PhoneNumber


End Select
End With
End If
End If

Next itm

Set s = Nothing

'waitTime = Now + TimeValue("00:00:05")
'Application.Wait waitTime
'appIE.Refresh

Set cn = cn.Offset(1, 0)
Set cf = cf.Offset(1, 0)
Set cc = cc.Offset(1, 0)
Set cs = cs.Offset(1, 0)
'Set cz = cz.Offset(1, 0)
Loop

Set appIE = Nothing
End Sub
Sub dump(myDoc)

With Sheets("sheet3")
RowCount = 1
For Each itm In myDoc.all
Range("A" & RowCount) = itm.tagName
Range("B" & RowCount) = itm.className
Range("C" & RowCount) = itm.ID
Range("D" & RowCount) = Left(itm.innerText, 1024)


RowCount = RowCount + 1
Next itm
End With

End Sub


--
joel
------------------------------------------------------------------------
joel's Profile: http://www.thecodecage.com/forumz/member.php?userid=229
View this thread: http://www.thecodecage.com/forumz/sh...d.php?t=152149

Microsoft Office Help