Please Help, Excel to Website and web data back to Excel

A

Alpineman2

For some reason I can't figure this out and need your help. Apprciate your
suggestions and help

I am having trouble extracting just the value of Name, Address, Phone.
Here is what I am trying to accomplish along with the code I've written thus
far. I have input to website via xls, but am having a tough time with the web
extraction.

An Excel database 'sheet11' consisting of properties and property contacts.
Each row contains a property and related contacts.

1. Extract the 1 or Many results (i.e. name, address, and phone number)
along with the corresponding Property "PIN", in 'sheet11'.

2. There may be more than one related contact for any one property, all
property related contacts are on the same row.


Example (xls sheet1)
PIN+lastname+firstname+city+state+zip+lastname2+firstname2+city2
1212123123, Doe, John, Chicago, IL, 60601, Smith, James, Plainfield

///////////////////////////////////////////////////////////////////////////////
Sub AnyWhoSearch()

'This project includes references to "Microsoft Internet Controls,
Microsoft HTML Object Library"

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

appIE.document.all.Item
For I = 0 To
appIE.document.getElementsByTagName("TD").Length - 1
Set s = appIE.document.getElementsByTagName("TD").Item(I)
txt = s.getAttribute("innerHTML")
cContact.Value = txt
Exit For
Next
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

errHandler:
appIE.Quit: Set appIE = Nothing
End Sub
//////////
 
J

Joel

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
 
J

Joel

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
 
J

Joel

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
 
A

Alpineman2

You assume correctly, I am extracting so much more than required.
I'll give your revision a shot and let you know how it turns out.
 
A

Alpineman2

Joel,

Works well still needs some revision, but I greatly appreciate your
assitance. The current Set cn, etc... writes over the previous Set cn, etc...
I'll post the revisions as soon as complete.
On another note, do you do programming on the side/job? If so, I'd like to
run a few jobs past you.

Thanks,

Brice
 
A

Alpineman2

Joel,

For some reason I can't figure out why the current 'itm' is writing over the
previous 'itm'. Could you please enlighten me?

Thanks,

Brice
 
A

Alpineman2

Joel,

Here is what I have so the 'itm' doesn't overwrite previous 'itm', however,
if there is more than one result only one result 'itm' is provided. Let me
know if you have any suggestions.

Thanks again,

Brice

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 waitTime As Variant
Dim cn As Range
Dim cf As Range
Dim cc As Range
Dim cs As Range
'Dim cz As Range
Dim LastCl As Range
Set LastCl = Range("a65536").End(xlUp)

'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 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 = LastCl
For Each itm In myDoc.all
If itm.tagName = "TABLE" And _
itm.className = "resultTable" Then
Found_Results = True
DIV_Count = 0
LastCl = 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" & LastCl) = FullName
Case 3
Address = itm.innerText
.Range("B" & LastCl) = Address
Case 4
PhoneNumber = itm.innerText
.Range("C" & LastCl) = PhoneNumber
End Select
End With
End If
End If
Next itm

waitTime = Now + TimeValue("00:00:02")
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)
Loop

Set appIE = Nothing
appIE.Quit
End Sub
 
J

Joel

The microsoft webpage still isn't getting the messages posted at the
THECODECAGE.COM. I posted this earlier but you didn't get the message.


I found three things that need to be fixed

1) From
Set LastCl = Range("a65536").End(xlUp)
to
Set LastCl = Sheets:)Sheet2").Range("a65536").End(xlUp)[/QUOTE]

2) Remove
RowCount = LastCl

3) Change this

From
LastCl = RowCount + 1
to
LastCl = LastCl + 1
 
A

Alpineman2

Joel,

Here is what I have and seems to work well, thank you very much for your help.
If you don't mind I have one more question. How would I go about placing
multiple results for one contact in adjacent rows (to right)? I've tried a
few revisions but none seem to work.

The below places contacts found in same row as the look-up value. So, if
there is non found it leaves the row blank and go to the next row.

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 waitTime As Variant
Dim cn As Range
Dim cf As Range
Dim cc As Range
Dim cs As Range
'Dim cz As Range
Dim LastCl As Range
Set LastCl = Range("a65536").End(xlUp)

'On Error GoTo errHandler

'Set starting range (first cell of data)
Set cn = Sheets("Sheet10").Range("e11555")
Set cf = Sheets("Sheet10").Range("f11555")
Set cc = Sheets("Sheet10").Range("k11555")
Set cs = Sheets("Sheet10").Range("l11555")
'Set cContact = Sheets("Sheet1").Range("f2")
'Set ca = Sheets("Sheet1").Range("g2")
'Set cp = Sheets("Sheet1").Range("h2")
'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 = LastCl
For Each itm In myDoc.all
If itm.tagName = "TABLE" And _
itm.className = "resultTable" Then
Found_Results = True
DIV_Count = 0
'LastCl = RowCount + 1
End If
If Found_Results = True Then
If itm.tagName = "DIV" Then
DIV_Count = DIV_Count + 1
With Sheets("Sheet10")
Select Case DIV_Count
Case 1
FullName = itm.innerText
cn.Offset(0, 49) = FullName
Case 3
Address = itm.innerText
cn.Offset(0, 50) = Address
Case 4
PhoneNumber = itm.innerText
cn.Offset(0, 51) = PhoneNumber
End Select
End With
End If
End If
Next itm
'Set s = Nothing



appIE.Refresh

waitTime = Now + TimeValue("00:00:01")
Application.Wait waitTime

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

errHandler:
appIE.Quit: Set appIE = Nothing
End Sub

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 waitTime As Variant
Dim cn As Range
Dim cf As Range
Dim cc As Range
Dim cs As Range
'Dim cz As Range
Dim LastCl As Range
Set LastCl = Range("a65536").End(xlUp)

'On Error GoTo errHandler

'Set starting range (first cell of data)
Set cn = Sheets("Sheet10").Range("e11555")
Set cf = Sheets("Sheet10").Range("f11555")
Set cc = Sheets("Sheet10").Range("k11555")
Set cs = Sheets("Sheet10").Range("l11555")
'Set cContact = Sheets("Sheet1").Range("f2")
'Set ca = Sheets("Sheet1").Range("g2")
'Set cp = Sheets("Sheet1").Range("h2")
'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 = LastCl
For Each itm In myDoc.all
If itm.tagName = "TABLE" And _
itm.className = "resultTable" Then
Found_Results = True
DIV_Count = 0
'LastCl = RowCount + 1
End If
If Found_Results = True Then
If itm.tagName = "DIV" Then
DIV_Count = DIV_Count + 1
With Sheets("Sheet10")
Select Case DIV_Count
Case 1
FullName = itm.innerText
cn.Offset(0, 49) = FullName
Case 3
Address = itm.innerText
cn.Offset(0, 50) = Address
Case 4
PhoneNumber = itm.innerText
cn.Offset(0, 51) = PhoneNumber
End Select
End With
End If
End If
Next itm
'Set s = Nothing



appIE.Refresh

waitTime = Now + TimeValue("00:00:01")
Application.Wait waitTime

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

errHandler:
appIE.Quit: Set appIE = Nothing
End Sub

Joel said:
The microsoft webpage still isn't getting the messages posted at the
THECODECAGE.COM. I posted this earlier but you didn't get the message.


I found three things that need to be fixed

1) From
Set LastCl = Range("a65536").End(xlUp)
to
Set LastCl = Sheets:)Sheet2").Range("a65536").End(xlUp)
Click to expand...

2) Remove
RowCount = LastCl

3) Change this

From
LastCl = RowCount + 1
to
LastCl = LastCl + 1


Alpineman2 said:
Joel,

Here is what I have so the 'itm' doesn't overwrite previous 'itm', however,
if there is more than one result only one result 'itm' is provided. Let me
know if you have any suggestions.

Thanks again,

Brice

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 waitTime As Variant
Dim cn As Range
Dim cf As Range
Dim cc As Range
Dim cs As Range
'Dim cz As Range
Dim LastCl As Range
Set LastCl = Range("a65536").End(xlUp)

'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 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 = LastCl
For Each itm In myDoc.all
If itm.tagName = "TABLE" And _
itm.className = "resultTable" Then
Found_Results = True
DIV_Count = 0
LastCl = 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" & LastCl) = FullName
Case 3
Address = itm.innerText
.Range("B" & LastCl) = Address
Case 4
PhoneNumber = itm.innerText
.Range("C" & LastCl) = PhoneNumber
End Select
End With
End If
End If
Next itm

waitTime = Now + TimeValue("00:00:02")
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)
Loop

Set appIE = Nothing
appIE.Quit
End Sub
Click to expand...
[/QUOTE]
 
J

Joel

I added Colcount to this section of the code

Found_Results = False
'RowCount = LastCl
ColCount = 49
For Each itm In myDoc.all
If itm.tagName = "TABLE" And _
itm.className = "resultTable" Then

Found_Results = True
DIV_Count = 0
'LastCl = RowCount + 1
End If

If Found_Results = True Then
If itm.tagName = "DIV" Then
DIV_Count = DIV_Count + 1
With Sheets("Sheet10")
Select Case DIV_Count

Case 1
FullName = itm.innerText
cn.Offset(0, ColCount) = FullName
Case 3
Address = itm.innerText
cn.Offset(0, ColCount + 1) = Address
Case 4
PhoneNumber = itm.innerText
cn.Offset(0, ColCount + 2) = PhoneNumber
ColCount = Colcount + 3
End Select
End With
End If
End If
Next itm
'Set s = Nothing

Alpineman2 said:
Joel,

Here is what I have and seems to work well, thank you very much for your help.
If you don't mind I have one more question. How would I go about placing
multiple results for one contact in adjacent rows (to right)? I've tried a
few revisions but none seem to work.

The below places contacts found in same row as the look-up value. So, if
there is non found it leaves the row blank and go to the next row.

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 waitTime As Variant
Dim cn As Range
Dim cf As Range
Dim cc As Range
Dim cs As Range
'Dim cz As Range
Dim LastCl As Range
Set LastCl = Range("a65536").End(xlUp)

'On Error GoTo errHandler

'Set starting range (first cell of data)
Set cn = Sheets("Sheet10").Range("e11555")
Set cf = Sheets("Sheet10").Range("f11555")
Set cc = Sheets("Sheet10").Range("k11555")
Set cs = Sheets("Sheet10").Range("l11555")
'Set cContact = Sheets("Sheet1").Range("f2")
'Set ca = Sheets("Sheet1").Range("g2")
'Set cp = Sheets("Sheet1").Range("h2")
'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 = LastCl
For Each itm In myDoc.all
If itm.tagName = "TABLE" And _
itm.className = "resultTable" Then
Found_Results = True
DIV_Count = 0
'LastCl = RowCount + 1
End If
If Found_Results = True Then
If itm.tagName = "DIV" Then
DIV_Count = DIV_Count + 1
With Sheets("Sheet10")
Select Case DIV_Count
Case 1
FullName = itm.innerText
cn.Offset(0, 49) = FullName
Case 3
Address = itm.innerText
cn.Offset(0, 50) = Address
Case 4
PhoneNumber = itm.innerText
cn.Offset(0, 51) = PhoneNumber
End Select
End With
End If
End If
Next itm
'Set s = Nothing



appIE.Refresh

waitTime = Now + TimeValue("00:00:01")
Application.Wait waitTime

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

errHandler:
appIE.Quit: Set appIE = Nothing
End Sub

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 waitTime As Variant
Dim cn As Range
Dim cf As Range
Dim cc As Range
Dim cs As Range
'Dim cz As Range
Dim LastCl As Range
Set LastCl = Range("a65536").End(xlUp)

'On Error GoTo errHandler

'Set starting range (first cell of data)
Set cn = Sheets("Sheet10").Range("e11555")
Set cf = Sheets("Sheet10").Range("f11555")
Set cc = Sheets("Sheet10").Range("k11555")
Set cs = Sheets("Sheet10").Range("l11555")
'Set cContact = Sheets("Sheet1").Range("f2")
'Set ca = Sheets("Sheet1").Range("g2")
'Set cp = Sheets("Sheet1").Range("h2")
'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 = LastCl
For Each itm In myDoc.all
If itm.tagName = "TABLE" And _
itm.className = "resultTable" Then
Found_Results = True
DIV_Count = 0
'LastCl = RowCount + 1
End If
If Found_Results = True Then
If itm.tagName = "DIV" Then
DIV_Count = DIV_Count + 1
With Sheets("Sheet10")
Select Case DIV_Count
Case 1
FullName = itm.innerText
cn.Offset(0, 49) = FullName
Case 3
Address = itm.innerText
cn.Offset(0, 50) = Address
Case 4
PhoneNumber = itm.innerText
cn.Offset(0, 51) = PhoneNumber
End Select
End With
End If
End If
Next itm
'Set s = Nothing



appIE.Refresh

waitTime = Now + TimeValue("00:00:01")
Application.Wait waitTime

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

errHandler:
appIE.Quit: Set appIE = Nothing
End Sub



2) Remove
RowCount = LastCl

3) Change this

From
LastCl = RowCount + 1
to
LastCl = LastCl + 1
Click to expand...
[/QUOTE]
 
A

Alpineman2

Works like a charm. You are the man. I looked and didn't see you on
thecodecage.com. Anyhow, thanks again and let me know if you do any work on
the side.

Joel said:
I added Colcount to this section of the code

Found_Results = False
'RowCount = LastCl
ColCount = 49
For Each itm In myDoc.all
If itm.tagName = "TABLE" And _
itm.className = "resultTable" Then

Found_Results = True
DIV_Count = 0
'LastCl = RowCount + 1
End If

If Found_Results = True Then
If itm.tagName = "DIV" Then
DIV_Count = DIV_Count + 1
With Sheets("Sheet10")
Select Case DIV_Count

Case 1
FullName = itm.innerText
cn.Offset(0, ColCount) = FullName
Case 3
Address = itm.innerText
cn.Offset(0, ColCount + 1) = Address
Case 4
PhoneNumber = itm.innerText
cn.Offset(0, ColCount + 2) = PhoneNumber
ColCount = Colcount + 3
End Select
End With
End If
End If
Next itm
'Set s = Nothing
Click to expand...
[/QUOTE]
 
A

Alpineman2

joel said:
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/showthread.php?t=152149

Microsoft Office Help
Click to expand...

Hi Joel,

I looked back at the post and noticed that you added something back about 1
week ago, however, am not sure if the code is different. Anyhow thanks again.

Brice
 
J

Joel

I don't know if you will ever get this message. The microsoft website has
been broken for a long time. the website is not sending out emails when
responses are posted.

There are at least 4 different websites that share postings.
Microsoft
MSN (a 2nd microsft website)
Google
TheCodeCage.

I've switched over to using the CodeCage. I use to be able to respond at
TheCodeCage and the message would appear at microsoft. About a week ago
microsoft stopped posting responses made at the TheCodeCage as well as the
previous problem of sending out emails.

I regularly check message at the TheCodeCage.com. If you need to contact me
put Joel in the title of the message and I should see it.

Alpineman2 said:
joel said:
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/showthread.php?t=152149

Microsoft Office Help
Click to expand...

Hi Joel,

I looked back at the post and noticed that you added something back about 1
week ago, however, am not sure if the code is different. Anyhow thanks again.

Brice
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

submit web form 1
fill a web form from excel vba 3
Transfer array element offset value to a matched value 3
Code works but goes into endless loop and crashes 1
Resize to last entry in row and copy to sheet 1 3
Sheet to sheet code Type Mismatch 6
Excel VBA help: Text file formatting 19
Open four Wbooks, copy four columns from each to Master Wbook 16

Top