I solved the problem myself. I found Excel makes an excellent debug package
when debugging HTML code. You can easily write data to the spreadsheet from
a webpage like this
rowCount = 1
for each itm in IE.document.all
Range("A" & RowCount) = itm.innertext
nextt itm
It took a lot of work but below its my entire code. You need to have two
sheets in your workbook call "Dealers" , and "Cars" (remove double quotes).
First run Sub GetDealers. This will get all the dealers in a 100 mile radius
of zip code 07508. Then Run Sub GetCars.
Sub GetDealers()
'Dim PageNumber As Object
CR = Chr(13)
LF = Chr(10)
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
URL = "
http://www.nissanusa.com/apps/dealerlocator"
Request = "?zipCode=07508&tool=Home.Locator"
'get web page
IE.Navigate2 URL & Request
Do While IE.readyState <> 4
DoEvents
Loop
'get search button
Set but = IE.document.getElementById("mainSearchButton")
'put distance in listbox on webpage
Set radius = IE.document.getElementById("radius")
radius.Value = "100"
'search again a larger distance
'Select Search button and activate
but.Select
but.Click
Set SearchResults = IE.document.getElementById("searchResults")
On Error Resume Next ' Defer error handling.
Do
Err.Clear
Set PageNumber = IE.document.getElementById("pageNumber")
Pages = PageNumber.Value
DoEvents
Loop While Err.Number <> 0
On Error GoTo 0
With Sheets("Dealers")
RowCount = 1
For PageCount = 1 To PageNumber.Length
PageNumber.Value = Format(PageCount, "@")
PageNumber.onchange
For Each Chld In SearchResults.Children
ChildRowCount = 1
For Each all In Chld.all
Sheets("Sheet3").Range("A" & ChildRowCount) = all.innertext
Sheets("Sheet3").Range("B" & ChildRowCount) = all.outerhtml
ChildRowCount = ChildRowCount + 1
Next all
If Chld.innertext = "" Then
Exit For
End If
Set DealerNumberObj = _
Chld.getelementsbytagname("A")
DealerNumberStr = DealerNumberObj.Item(1).pathname
dealerNumber = _
Val(Mid(DealerNumberStr, InStr(DealerNumberStr, "'") + 1))
.Cells(RowCount, "A") = dealerNumber
ColCount = 2
dealer = Chld.innertext
Do While InStr(dealer, CR) > 0
Data = Trim(Left(dealer, InStr(dealer, CR) - 1))
'remove leading CR and LF
Do While Left(Data, 1) = LF Or _
Left(Data, 1) = CR
Data = Mid(Data, 2)
Loop
dealer = Trim(Mid(dealer, InStr(dealer, CR) + 1))
If InStr(Data, "(") > 0 And _
ColCount = 4 Then
Distance = Trim(Mid(Data, InStr(Data, "(") + 1))
Distance = Trim(Left(Distance, InStr(Distance, ")") - 1))
CityState = Trim(Left(Data, InStr(Data, "(") - 1))
.Cells(RowCount, ColCount) = CityState
.Cells(RowCount, (ColCount + 1)) = Distance
ColCount = ColCount + 2
Else
.Cells(RowCount, ColCount) = Data
ColCount = ColCount + 1
End If
Loop
'remove leading CR and LF
Do While Left(dealer, 1) = LF Or _
Left(dealer, 1) = CR
dealer = Mid(dealer, 2)
Loop
.Cells(RowCount, ColCount) = dealer
RowCount = RowCount + 1
Next Chld
Next PageCount
End With
End Sub
Sub GetCars()
Dim DealerName As String
Dim City As String
Dim Distance As String
Dim Bodytype(2) As String
Dim BodyStyle As String
Bodytype(0) = "alt" 'sedan
Bodytype(1) = "alc" 'coupe
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
URL = "
http://www.config.nissanusa.com/redirect.jsp"
Sheets("Cars").Cells.ClearContents
With Sheets("Dealers")
RowCount = 25
Do While .Range("A" & RowCount) <> ""
dealerNumber = .Range("A" & RowCount)
DealerName = .Range("B" & RowCount)
City = .Range("D" & RowCount)
Distance = .Range("E" & RowCount)
Request = "?make=nissan&" & _
"model=null&" & _
"year=null&" & _
"flow=browse&" & _
"dealer=" & dealerNumber & "&" & _
"next=Locate.SearchInventory&" & _
"nextInInventory=dealer_inventory&" & _
"rpl=false&x=&zip=07508&Site=&lang=en"
IE.Navigate2 URL & Request
Do While IE.readyState <> 4
DoEvents
Loop
Do While IE.busy = True
DoEvents
Loop
URL = "
http://www.config.nissanusa.com/Dispatch.jsp"
For body = 0 To 1
If body = 0 Then
BodyStyle = "Sedan"
Else
BodyStyle = "Coupe"
End If
Request = "?changeModel=execute&" & _
"currentBodyType=" & Bodytype(body) & "&" & _
"_scrollPos=158&" & _
"locateConfig=true&" & _
"__action4=&" & _
"state_token=2%3A17%3Anissan%7Calt%7CALL%7C0%7CA4AAAAAAAAAA%7C%3A&" & _
".CurrentState=DealerMatchingVehiclesBrowse&" & _
"unselectVehicle=null&" & _
"tool=null&" & _
"sdealerID=" & dealerNumber & "&" & _
"sdealerContactable=true&" & _
"error_noResults=&"
Page = 0
Do
PageRequest = Request & "page=" & Page & "&"
IE.Navigate2 URL & PageRequest
Do While IE.readyState <> 4
DoEvents
Loop
Do While IE.busy = True
DoEvents
Loop
Call GetCarDetails(IE, DealerName, City, Distance, BodyStyle)
If IE.document.getelementsbytagname("B").Length <> 0 Then
Set PageNumbers = _
IE.document.getelementsbytagname("B") _
.Item(0).nextsibling
If Not PageNumbers Is Nothing Then
Page = Val(PageNumbers.innertext) - 1
End If
Else
Set PageNumbers = Nothing
End If
Loop While Not PageNumbers Is Nothing
RowCount = RowCount + 1
Next body
Loop
End With
End Sub
Public Enum States
NoState = 0
GetVehicleCount = 1
GetOption = 2
End Enum
Sub GetCarDetails(IE As Variant, _
DealerName As String, _
City As String, _
Distance As String, _
BodyStyle As String)
Dim Header As String
Dim DetailHeader As String
Set SearchResults = IE.document.getelementsbytagname("DIV")
State = NoState
CarRow = Sheets("Cars").Range("A" & Rows.Count).End(xlUp).Row
If CarRow = 1 Then
Sheets("Cars").Cells(1, "A") = "Dealer Name"
Sheets("Cars").Cells(1, "B") = "City"
Sheets("Cars").Cells(1, "C") = "Distance"
Sheets("Cars").Cells(1, "D") = "Body Style"
End If
DetailHeader = ""
For Each ClassItem In SearchResults
innertext = Trim(ClassItem.innertext)
Class = Trim(ClassItem.ClassName)
Select Case Class
Case "image_result-field"
CarRow = CarRow + 1
State = GetVehicleCount
CountRow = 0
Sheets("Cars").Cells(CarRow, "A") = _
DealerName
Sheets("Cars").Cells(CarRow, "B") = _
City
Sheets("Cars").Cells(CarRow, "C") = _
Distance
Sheets("Cars").Cells(CarRow, "D") = _
BodyStyle
Case "model-name"
HeaderCol = GetHeader("Model")
Sheets("Cars").Cells(CarRow, HeaderCol) = _
innertext
State = NoState
Case "vehicle-detail"
If InStr(innertext, ":") > 0 Then
Header = _
Trim(Left(innertext, InStr(innertext, ":") - 1))
HeaderCol = GetHeader(Header)
Detail = _
Trim(Mid(innertext, InStr(innertext, ":") + 1))
Sheets("Cars").Cells(CarRow, HeaderCol) = _
Detail
Else
HeaderCol = GetHeader(DetailHeader)
Sheets("Cars").Cells(CarRow, HeaderCol) = _
innertext
DetailHeader = ""
End If
State = NoState
Case "vehicle-detail-header"
DetailHeader = innertext
Select Case DetailHeader
Case "Packages and Options", _
"Accessories"
CountRow = 0
State = GetOption
Case Else
State = NoState
End Select
End Select
Select Case State
Case GetVehicleCount
'wait two rows
If CountRow = 2 Then
If innertext = "" Then
VehicleCount = 1
Else
VehicleCount = Val(innertext)
End If
End If
Header = "Number of Cars"
HeaderCol = GetHeader(Header)
Sheets("Cars").Cells(CarRow, HeaderCol) = _
VehicleCount
Case GetOption
If CountRow = 1 Then
HeaderCol = GetHeader(DetailHeader)
Sheets("Cars").Cells(CarRow, HeaderCol) = _
innertext
DetailHeader = ""
End If
End Select
CountRow = CountRow + 1
Next ClassItem
End Sub
Function GetHeader(Header As String)
With Sheets("Cars")
Set c = .Rows(1).Find(what:=Header, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
.Cells(1, LastCol + 1).Value = Header
GetHeader = LastCol + 1
Else
GetHeader = c.Column
End If
End With
End Function
