Solved: Total distance and time between two cities in a state

[vishwakarma]

Hi All,

I want to find the total distance from between two cities in a particular state.

For Example :- Let say I have a list of cities in California like in one column A, and I want to find the total distance and time between Santa Ana and all the cities listed below and paste it the next cell front of the corresponding cities listed.
Column A - - -Column B
Cities - - -Total Travel Estimate:(Distance/Time)
Los Angeles
San Diego
San Jose
San Francisco
Long Beach
Fresno
Sacramento
Oakland


Website :- http://www.mapquest.com/ (http://www.mapquest.com/) ( There are three tabs on this page :- Maps, Directions, What’s New); this info can be retrieve from “Directions” tab of the web page…


Also attached is the sheet for reference...


Any help is appreciated..



Thanks in advance

[vishwakarma]

Hello Guys,

Can any one help me on this? :help Sorry... but this is something I really looking forward to.


Thank You...

[Aussiebear]

Please look at the below link and see if you can copy distances from this site.

http://www.mapcrow.info/united_states.html

[vishwakarma]

Hi Aussiebear, Thanks for the link....:hi:

But this is not what I m looking for. Though with the help of the link I can get the total distance but for a few cities listed on the page. What I need is a code which can copy the data from the excel sheet and visit the site, paste that info in the search page and hit enter and then copy the answers(in this case the distance and time both) in excel in the front of the city name.

My list can contains numerous list of cities segregated by states...

It is not necessary that the website should be the same as I have listed in the earlier post, it can be any other through which we can export the data through this process.

If any one can please help me in getting this data. I will be really grateful.Thanks

[Aussiebear]

Sorry but i think you need to do more research. This sort of information is already out there, it just needs to be located

[vishwakarma]

Hello Guys....

Here is what I got after googling. And as I don't have relevant knowledge of VB, I'm not able to figure out what and where is the problem. After pasting this info and activating the "Microsoft DAO 3.6 Object Library" in my excel(2007) on VBA Page. I'm still getting a compile Error saying " User-defined type not defined"... Please Help:help


Public Function GetDistance(startAddr As String, startCity As String, _
startState As String, startZip As String, endAddr As String, _
endCity As String, endState As String, endZip As String) As String

Dim sURL As String
Dim appIE As InternetExplorer
Dim regex As RegExp, Regmatch As MatchCollection
Dim BodyTxt As String
Dim GetFirstPos As Long

sURL = "http://www.mapquest.com/directions?1c=" & Replace(startCity, " ", "+")
sURL = sURL & "&1s=" & startState & "&1a=" & Replace(startAddr, " ", "+")
sURL = sURL & "&1z=" & startZip & "&2c=" & endCity & "&2s=" & endState
sURL = sURL & "&2a=" & Replace(endAddr, " ", "+") & "&2z=" & endZip

Set appIE = New InternetExplorer
'Set appIE = CreateObject("Internetexplorer.application")

appIE.navigate sURL
appIE.Visible = True

Do
DoEvents
Loop Until appIE.readyState = READYSTATE_COMPLETE

appIE.Refresh

Set regex = New RegExp
With regex
.Pattern = "Total Estimated Distance"
.MultiLine = False
End With

BodyTxt = appIE.document.Body.innerText
Set Regmatch = regex.Execute(BodyTxt)

If Regmatch.Count > 0 Then
GetFirstPos = WorksheetFunction.Find("Total Estimated Distance", BodyTxt, 1)

GetDistance = Mid$(BodyTxt, GetFirstPos, 30)

Else
GetDistance = "Address Error, fix and try again"
End If

appIE.Quit
Set appIE = Nothing
Set regex = Nothing
Set Regmatch = Nothing

End Function

[JKwan]

You need to Reference:
Microsoft Internet Controls
Microsoft VBScript Regular Expressions n.n

[khushii]

:think:

[vishwakarma]

Thanks JKwan,

However, now I'm facing a new problem. It is giving me #VALUE error as result.

' must set references to Microsoft VBScript Regular Expressions, Internet Controls
' & HTML Object Library before running this script
' based on http://www.vbaexpress.com/kb/getarticle.php?kb_id=386

Public Function GetDistance(startAddr As String, startCity As String, _
startState As String, startZip As String, endAddr As String, _
endCity As String, endState As String, endZip As String) As String
Dim sURL As String
Dim appIE As InternetExplorer
Dim regex As RegExp, Regmatch As MatchCollection
Dim BodyTxt As String
Dim GetFirstPos As Long
sURL = "http://www.mapquest.com/maps?1c=" & Replace(startCity, " ", "+")
sURL = sURL & "&1s=" & startState & "&1a=" & Replace(startAddr, " ", "+")
sURL = sURL & "&1z=" & startZip & "&2c=" & endCity & "&2s=" & endState
sURL = sURL & "&2a=" & Replace(endAddr, " ", "+") & "&2z=" & endZip
Set appIE = New InternetExplorer
'Set appIE = CreateObject("Internetexplorer.application")
appIE.navigate sURL
appIE.Visible = False
Do
DoEvents
Loop Until appIE.readyState = READYSTATE_COMPLETE
appIE.Refresh
Set regex = New RegExp
With RegExp
.Pattern = "Total Estimated Distance "
.MultiLine = False
End With
BodyTxt = appIE.document.Body.htmlText
Set Regmatch = regex.Execute(BodyTxt)
If Regmatch.Count > 0 Then
GetFirstPos = WorksheetFunction.Find("Total Estimated Distance", BodyTxt, 1)

GetDistance = Mid$(BodyTxt, GetFirstPos, 30)

Else
GetDistance = "Address Error, fix and try again"
End If
appIE.Quit
Set appIE = Nothing
Set regex = Nothing
Set Regmatch = Nothing
End Function

[Aussiebear]

When posting code to the forum, please select your code then click the green "VBA" button. I have done this for you on this occassion, and as you can see it formats the code into something easily readable.

[vishwakarma]

Thanks...:hi:

I will keep in mind in future before posting any code... :jsmile:

[JKwan]

I don't have that problem, after I fixed your RegEx and a few variables errror as well.

Public Function GetDistance(startAddr As String, startCity As String, _
startState As String, startZip As String, endAddr As String, _
endCity As String, endState As String, endZip As String) As String
Dim sURL As String
Dim appIE As InternetExplorer
Dim regex As RegExp, Regmatch As MatchCollection
Dim BodyTxt As String
Dim GetFirstPos As Long
sURL = "http://www.mapquest.com/maps?1c=" & Replace(startCity, " ", "+")
sURL = sURL & "&1s=" & startState & "&1a=" & Replace(startAddr, " ", "+")
sURL = sURL & "&1z=" & startZip & "&2c=" & endCity & "&2s=" & endState
sURL = sURL & "&2a=" & Replace(endAddr, " ", "+") & "&2z=" & endZip
Set appIE = New InternetExplorer
'Set appIE = CreateObject("Internetexplorer.application")
appIE.navigate sURL
appIE.Visible = True
Do
DoEvents
Loop Until appIE.readyState = READYSTATE_COMPLETE
appIE.Refresh
Set regex = New RegExp
With regex
.Pattern = "Total Travel Estimate:"
.MultiLine = False
End With
BodyTxt = appIE.document.Body.innerText
Set Regmatch = regex.Execute(BodyTxt)
If Regmatch.Count > 0 Then
GetFirstPos = WorksheetFunction.Find("Total Travel Estimate:", BodyTxt, 1)

GetDistance = Mid$(BodyTxt, GetFirstPos, 50)

Else
GetDistance = "Address Error, fix and try again"
End If
appIE.Quit
Set appIE = Nothing
Set regex = Nothing
Set Regmatch = Nothing
End Function

[vishwakarma]

Hi JKwan,

I'm still getting the same value error. I think I have not selected the proper references in the vba.

I'm listing the all the references which are selected in VBA of my sheet. I'm using Excel 2007
- Visual Basic for Applications
- Microsoft excel 12.0 Object Library
- Microsoft HTML Object Library
- Microsoft Internet Controls
- Microsoft VBScript Regular Expressions 5.5

Please let me know if I'm doing something wrong. Also, if possible can you please sent me your sample excel file in which you have this code.


Thanks... :)

[vishwakarma]

OK Guys,

The code is working fine but there is one issue. I want to autoclick the Message Box that get popped up before the value is pasted in the sheet. Message box displays "Loaded VBAX link". I want it to be autoclicked through VBA so that I don't have to click every time.

Any idea how to do it?

[vishwakarma]

Hello... sorry to disturb you guys again and again, but can anyone help me on this... I'm attaching my excel sheet for your reference.

The code is running good but I still have a problem with it. Every time I run this UDF. A message box appear (because it is defined in it) and untill and unless I click on this message box it will not return the value. Also, if I click on this a little early it will give me an #VALUE error. I don't want this message box to appear and I get my desired result. Is there any way to do this? ... Thanks..

[Shred Dude]

You could probably adapt this to other sources, but Google makes it pretty easy.

Try this:


Public Function getGoogDistanceTime(startAddr As String, startCity As String, _
startState As String, startZip As String, endAddr As String, _
endCity As String, endState As String, endZip As String) As String

Dim sURL As String
Dim HTTPreq As Object
Dim BodyTxt As String
Dim s As String, _
d As String, _
t As String

sURL = "http://maps.google.com/maps?f=d&source=s_d&saddr="
sURL = sURL & Replace(startAddr, " ", "+") & ",+" & Replace(startCity, " ", "+") & ",+" & startState
sURL = sURL & "&daddr=" & Replace(endAddr, " ", "+") & ",+" & Replace(endCity, " ", "+") & ",+" & endState
sURL = sURL & "&hl=en"

Set HTTPreq = CreateObject("msxml2.xmlhttp")
With HTTPreq
.Open "get", sURL, False
.send
BodyTxt = .responseText
End With
Set HTTPreq = Nothing

s = "distance:"""

If InStr(1, BodyTxt, s) = 0 Then getGoogDistanceTime = "Error": Exit Function

d = Mid(BodyTxt, InStr(1, BodyTxt, s) + Len(s))
d = Mid(d, 1, InStr(1, d, """") - 1)

s = "time:"""
t = Mid(BodyTxt, InStr(1, BodyTxt, s) + Len(s))
t = Mid(t, 1, InStr(1, t, """") - 1)

getGoogDistanceTime = d & " / " & t

End Function

Cleaned it up a little...

Public Function getGoogDistanceTime(startAddr As String, startCity As String, _
startState As String, startZip As String, endAddr As String, _
endCity As String, endState As String, endZip As String) As String

Dim sURL As String
Dim BodyTxt As String

sURL = "http://maps.google.com/maps?f=d&source=s_d&saddr="
sURL = sURL & Replace(startAddr, " ", "+") & ",+" & Replace(startCity, " ", "+") & ",+" & startState
sURL = sURL & "&daddr=" & Replace(endAddr, " ", "+") & ",+" & Replace(endCity, " ", "+") & ",+" & endState
sURL = sURL & "&hl=en"

BodyTxt = getHTML(sURL)

If InStr(1, BodyTxt, "distance:""") = 0 Then getGoogDistanceTime = "Error": Exit Function

getGoogDistanceTime = parseGoog("distance", BodyTxt) & " / " & parseGoog("time", BodyTxt)

End Function

Public Function getHTML(strURL As String) As String
'Returns the HTML code underlying a given URL
Dim oXH As Object
Set oXH = CreateObject("msxml2.xmlhttp")
With oXH
.Open "get", strURL, False
.send
getHTML = .responseText
End With
Set oXH = Nothing
End Function


Public Function parseGoog(strSearch As String, strHTML As String) As String
strSearch = strSearch & ":"""
If InStr(1, strHTML, strSearch) = 0 Then parseGoog = "Not Found": Exit Function
parseGoog = Mid(strHTML, InStr(1, strHTML, strSearch) + Len(strSearch))
parseGoog = Mid(parseGoog, 1, InStr(1, parseGoog, """") - 1)
End Function

[vishwakarma]

Awesome Man....

This is working like a magic..:bow:

Thanks a lot....

Manoj

[Morglam]

Hi,

Just wanted to say that this code has saved my life with my thesis work...thanks a lot!

However, I just wanted to know if is possible to just give to the formula the geographical coordinates (google maps easily recognizes them) instead of the 4 fields (adress, city, state, code) and what changes shoud I do to the code.

Thanks in advance, nice work!

[JP2112]

Maybe something from Latitude Longitude Functions (http://www.codeforexcelandoutlook.com/excel-vba/latitude-longitude-functions/) can help?

[Morglam]

Thanks for the tip. Unfortunately, I think that it doesn't show how to calculate the driving distance with two geographical coordinates given, just with the adressses.

With the adresses the code works just fine but most of the places I need to geolocate are in tracks with no adress, so the accuracy of my work is affected. I'm no VBA expert, so maybe it's easy to combine some codes but it will be a nightmare for me.

Any help is really welcomed!

[JP2112]

All of the driving directions APIs I've found so far require street addresses, and don't take lat/lon pairs. I'd be super happy to hear otherwise.

By the way MapQuest also has a driving directions API, and their TOS (unlike Google's) doesn't require you to display a map:

http://www.mapquestapi.com/directions/

[Morglam]

OK, I'll check that out, thanks a lot.

[Shred Dude]

Here you go...

Attached workbook contains new Class Module to encapsulate functionality.

Two public Functions in a Module expose methods of the class:

distCoords, and distAddresses

Use as formulas from Module:

=getAddressDistance(...
=getCoordDistance(stCoords As String, EndCoords As String)

[Morglam]

Wow man...it works perfectly...don't know how to thank you...

The least I could do is put you on the acknowledgment section of the article I'm (hopefully) to publish. I you feel like it don't hesitate to give me your full name and institution of reference.

Thank you again!

Regards,

[vishwakarma]

Hi Guys,

Can you please help in the code below it is showing me kind of weird error, it was working perfectly untill yesterday but when I tried it today, it is showing me error of every records.



Public Function getGoogDistanceTime(startAddr As String, startCity As String, _
startState As String, startZip As String, endAddr As String, _
endCity As String, endState As String, endZip As String) As String


Dim sURL As String
Dim BodyTxt As String


sURL = "http://maps.google.com/maps?f=d&source=s_d&saddr="
sURL = sURL & Replace(startAddr, " ", "+") & ",+" & Replace(startCity, " ", "+") & ",+" & startState
sURL = sURL & "&daddr=" & Replace(endAddr, " ", "+") & ",+" & Replace(endCity, " ", "+") & ",+" & endState
sURL = sURL & "&hl=en"


BodyTxt = getHTML(sURL)


If InStr(1, BodyTxt, "distance:""") = 0 Then getGoogDistanceTime = "Error": Exit Function


getGoogDistanceTime = parseGoog("distance", BodyTxt) & " / " & parseGoog("time", BodyTxt)


End Function


Public Function getHTML(strURL As String) As String
'Returns the HTML code underlying a given URL
Dim oXH As Object
Set oXH = CreateObject("msxml2.xmlhttp")
With oXH
.Open "get", strURL, False
.send
getHTML = .responseText
End With
Set oXH = Nothing
End Function



Public Function parseGoog(strSearch As String, strHTML As String) As String
strSearch = strSearch & ":"""
If InStr(1, strHTML, strSearch) = 0 Then parseGoog = "Not Found": Exit Function
parseGoog = Mid(strHTML, InStr(1, strHTML, strSearch) + Len(strSearch))
parseGoog = Mid(parseGoog, 1, InStr(1, parseGoog, """") - 1)
End Function


Please help me... I tried to work on it but not able to find the issue...

[Kenneth Hobs]

When parsing HTML source code, if your code relies on that code being consistent and that code does change, things go amiss. Looking at the source code, the first change that you might notice is that some double quotes were replaced by single quotes. I have not tried but try:

Private Function parseGoog(strSearch As String, strHTML As String) As String
strSearch = strSearch & ":'"
If InStr(1, strHTML, strSearch) = 0 Then parseGoog = "Not Found": Exit Function
parseGoog = Mid(strHTML, InStr(1, strHTML, strSearch) + Len(strSearch))
parseGoog = Mid(parseGoog, 1, InStr(1, parseGoog, "'") - 1)
End Function

[vishwakarma]

Hi Kenneth,

Thanks for the suggestion. I tried it but it is still not working and giving me the error plus now the file is hanging and not responding as well.

I'm attaching the file if in case you might want to test it.

Looking forward for your reply.


Thanks

[Kenneth Hobs]

There were too many problems with the one that you posted. I also changed to the WinHttp object and used the previous code modified with the single quote replacements. If the application is volatile then for every recalculation, other functions recalculates so if you have a problem, it is fairly circular and locks Excel. Ctrl+Break and ESC can help and even Application.Calculation=xlCalculationManual in the Immediate window will not stop the code from executing again.

Public Function getGoogDistanceTime(startAddr As String, StartCity As String, _
startState As String, StartZip As String, endAddr As String, _
EndCity As String, endState As String, EndZip As String) As String

Dim sURL As String
Dim HTTPreq As Object
Dim BodyTxt As String
Dim s As String, _
d As String, _
t As String

Application.Volatile False

sURL = "http://maps.google.com/maps?f=d&source=s_d&saddr="
sURL = sURL & Replace(startAddr, " ", "+") & ",+" & Replace(StartCity, " ", "+") & ",+" & startState
sURL = sURL & "&daddr=" & Replace(endAddr, " ", "+") & ",+" & Replace(EndCity, " ", "+") & ",+" & endState
sURL = sURL & "&hl=en"

'Set HTTPreq = CreateObject("msxml2.xmlhttp")
Set HTTPreq = CreateObject("WinHttp.WinHttpRequest.5.1")
With HTTPreq
.Open "GET", sURL, False
.send
.WaitForResponse
BodyTxt = .responseText
End With
Set HTTPreq = Nothing

s = "distance:'"

If InStr(1, BodyTxt, s) = 0 Then getGoogDistanceTime = "Error": Exit Function

d = Mid(BodyTxt, InStr(1, BodyTxt, s) + Len(s))
d = Mid(d, 1, InStr(1, d, "'") - 1)

s = "time:'"
t = Mid(BodyTxt, InStr(1, BodyTxt, s) + Len(s))
t = Mid(t, 1, InStr(1, t, "'") - 1)

getGoogDistanceTime = d & " / " & t

End Function



See cell I3 and Module 3 for the UDF. I have not worked on the others much to see what they need.

[vishwakarma]

Thanks a lot Kenneth...for your valuable help and suggestion...:beerchug:

[Morglam]

Sorry to bother, but the formula Shred Dude gave me seems to be no longer working. It doesn't return me any result. There has been any change in Google API or it's me?

I attach you the same file that was working like magic until some days ago. If anyone can help me out will save my life.

Thanks in advance.

[vishwakarma]

Hi,

Just try the code provided by Mr. Kenneth....

I've attached the sheet provided by him.

[Morglam]

Hi,

Thanks for the tip but the thing is that I need a formula that works with coordinates. Mr. Kenneth formula seems to work ok but it just works with addresses. I really don't get why the formula on the sheet I attached stopped working...

Please, any help will be welcomed.

Regards,

[vishwakarma]

please send the attachment..

[Morglam]

It's attached on my last post.

Regards,

[vishwakarma]

see if this works for you...

[Morglam]

Yeah, works fine! What was the matter then?

Thanks a lot.

Regards,

[vishwakarma]

When parsing HTML source code, if your code relies on that code being consistent and that code does change, things go amiss. Looking at the source code, the first change that you might notice is that some double quotes were replaced by single quotes. I have not tried but try:

VBA:

Private Function parseGoog(strSearch As String, strHTML As String) As String
strSearch = strSearch & ":'"
If InStr(1, strHTML, strSearch) = 0 Then parseGoog = "Not Found": Exit Function
parseGoog = Mid(strHTML, InStr(1, strHTML, strSearch) + Len(strSearch))
parseGoog = Mid(parseGoog, 1, InStr(1, parseGoog, "'") - 1)
End Function

[relima]

tks

[krishnak]

This looks to be a very elegant solution.

Somehow both variations (with Mapquest and Google) are not working on my Excel Application VBA window. I am getting "Error" in case of Google code and "Address Error, fix and try again" for Mapquest.

In both cases, the internet opens the website and displays the details of Driving directions with distance and time.

I have the following references in my VBA Editor:

Microsoft Excel 12.0 Object Library
Microsoft Internet Controls
Microsoft Office 12.0 Object Library
Microsoft Scripting Runtime
Microsoft HTML Object Library
Microsoft DAO 3.6 Object Library
Microsoft VBScript Regular Expressions 5.5

I am using Excel 2007.
What could be the problem?

[neverknow]

It was such a wonderful UDF, since about December, 14. Something changed and it no longer works. If you guys could be amazing again and fix it, I would really really appreciate it!

[Kenneth Hobs]

That is what we get for getting older, things start breaking and falling apart...

The xml output from the API has multiple roots so it does not lend itself well to standard xml parsing methods. I guess we could look at the json output but then we would probably just use our standard text parsing methods that are prone to failing again.

I noticed that the return results are just a bit different now, for:
10008 Falls Road Potomac MD 40854 500 EL Camino Real Santa Clara CA 95053.

It was 2,833 mi / 1 day 21 hours but is now 2,830 mi / 1 day 22 hours.

' Google API code directions:
' http://code.google.com/apis/maps/documentation/directions/

'=GoogleDistanceTime(A4,B4,C4,D4,E4,F4,G4,H4)
Public Function GoogleDistanceTime(startAddr As String, StartCity As String, _
startState As String, StartZip As String, endAddr As String, _
EndCity As String, endState As String, EndZip As String) As String

Dim xml As String, sDistance As String, sDuration As String
Dim sURL As String
Dim s As String, _
d As String, _
t As String

'http://maps.googleapis.com/maps/api/directions/xml?origin=Chicago,IL&destination=Los+Angeles,CA&waypoints=Joplin,MO|Oklahoma+City,OK&sensor=false
sURL = "http://maps.googleapis.com/maps/api/directions/xml?origin="
sURL = sURL & Replace(startAddr, " ", "+") & ",+" & Replace(StartCity, " ", "+") & ",+" & startState
sURL = sURL & "&destination=" & Replace(endAddr, " ", "+") & ",+" & Replace(EndCity, " ", "+") & ",+" & endState
sURL = sURL & "&sensor=false"

Application.Volatile False

xml = getXML(sURL)
sDistance = pGoog("distance", xml)
sDuration = pGoog("duration", xml)
GoogleDistanceTime = sDistance & " / " & sDuration
End Function

Private Function getXML(strURL As String) As String
Dim HTTPreq As Object
Dim BodyTxt As String

'Set HTTPreq = CreateObject("msxml2.xmlhttp")
Set HTTPreq = CreateObject("WinHttp.WinHttpRequest.5.1")
With HTTPreq
.Open "GET", strURL, False
.send
.WaitForResponse
BodyTxt = .responseText
End With
Set HTTPreq = Nothing
getXML = BodyTxt
End Function

Private Function pGoog(strSearch As String, strHTML As String) As String
Dim s As String
s = pRevTags(strSearch, strHTML)
pGoog = pRevTags("text", s)
End Function

Private Function pRevTags(strSearch As String, strHTML As String) As String
Dim s As String, p1 As Long, p2 As Long, lss As Integer
p1 = InStrRev(strHTML, "<" & strSearch & ">")
If p1 = 0 Then
pRevTags = "Not Found"
Exit Function
End If
p2 = InStrRev(strHTML, "</" & strSearch & ">")
lss = Len(strSearch)
s = Mid(strHTML, p1 + lss + 2, p2 - p1 - 2 - lss)
pRevTags = s
End Function

[developresou]

VERY USEFUL!

[vishwakarma]

Hi Guys,

My UDF is not working.. can someone please send me a file containing the UDF in working condition...

Many Thanks,

[Kenneth Hobs]

My code works fine. In your last file's L2:

=GoogleDistanceTime(A2,B2,C2,D2,E2,F2,G2,H2)

[vishwakarma]

Thanks Kenneth,

But it still not working, giving me Value error...

Thanks,

[Kenneth Hobs]

If you use your code, then I am not surprised. If you used mine, I would be surprised. Post a simple workbook with my code if you want me to check it out.

[vishwakarma]

Hi Kenneth,

attach is the sample workbook for your reference.


Many Thanks,

[Kenneth Hobs]

It worked fine for me in Excel 2010. I3 and I4 results were:
2,829 mi / 1 day 22 hours
710 mi / 11 hours 50 mins

[Bob Phillips]

Worked for me too, same results as Kenneth.

[Bob Phillips]

Even worked fine for my house to the Royal Academy London, without C, D, G or H values.

[Frost202]

Hi,

Just try the code provided by Mr. Kenneth....

I've attached the sheet provided by him.