All the webpages are diffferent and some are harder than other to get data.
this one is difficult. I assumed you may be getting more than one results
for each submission. I'm only return the first page of results.



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