Calculate driving distance between postcodes

[mwperkins]

Hi,
Years ago I used the following code to give me the distance (directly and via roads) between combinations of postcodes. It worked fine then, but I am guessing that something has changed on the web page because I now get a "Type mismatch" error on the following line:
Set Postcodebox4 = inputform.Item(6)



Sub Mod_49_Postcode_Distance_RUN()


Dim Xrow As Integer
Dim Ycol As Integer
Dim MsgTxt As String
Dim MsgTitleTxt As String
Dim iResponse As Integer
Dim strThisBook As String
Dim strThisSheet As String
Dim intProblems As Integer

' ********************************************************************************************
' Introductory Message - START
ThisBook = ActiveWorkbook.Name
ThisSheet = ActiveSheet.Name

Select Case Workbooks(ThisBook).Sheets(ThisSheet).Cells(3, 2)
Case True
MsgTitleTxt = "49 - Postcode Distance Calculator"
MsgTxt = "This utility uses www.freemaptools.com/distance-between-uk-postcodes.htm to calculate the distance between two postcodes."
MsgTxt = MsgTxt & vbCr & vbCr & "Internet Explorer is used to retrieve the information, but not shown on screen. the distances should simply appear in the spreadsheet"
MsgTxt = MsgTxt & vbCr & vbCr & "Note: The macro pauses three times to wait for the website to load or calculate the distance. Expect 10-15 seconds to calculate the distance between each pair of postcodes."
MsgTxt = MsgTxt & vbCr & "Despite having delays coded to wait for the website to calculate, this macro sometimes returns 0 or the same distance for multiple postcode pairs. Therefore, the code compares the answer returned and rescalculates of 0 or if the answer duplicates the previous pair of postcodes - It is therefore possible for the macro to get stuck in an eternal loop"
MsgTxt = MsgTxt & vbCr & vbCr & "Do you want to continue?"
iResponse = MsgBox(MsgTxt, vbYesNo, MsgTitleTxt)

Select Case iResponse
Case vbYes
MsgTxt = "Do you want to see this info again next time?"
iResponse = MsgBox(MsgTxt, vbYesNo, MsgTitleTxt)
Select Case iResponse
Case vbYes
Cells(3, 2) = True 'iResponse
Case vbNo
Cells(3, 2) = False
End Select
Case vbNo
MsgBox "bye"
Exit Sub
End Select
Case False
Cells(3, 2) = False
End Select
' Introductory Message - End
' ********************************************************************************************
Xrow = 11
Ycol = 1


Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = False 'True
URL = "http://www.freemaptools.com/distance-between-uk-postcodes.htm"
'get to first webpage
ie.Navigate2 URL
Do While ie.ReadyState <> 4 Or ie.Busy = True
DoEvents
Loop
Application.Wait Now + TimeValue("00:00:03") 'force a 3 second wait to give the webpage more time to load


With Workbooks(ThisBook).Sheets(ThisSheet)
Do While .Cells(Xrow, Ycol) <> ""
Cells(Xrow, Ycol).Select
StartLocation = .Cells(Xrow, Ycol).Value
EndLocation = .Cells(Xrow, Ycol + 1).Value
Set Form = ie.Document.getElementsByTagName("Form")
Set inputform = Form.Item(0)
Set Postcodebox = inputform.Item(0)
Postcodebox.Value = StartLocation
Set Postcodebox2 = inputform.Item(1)
Postcodebox2.Value = EndLocation
Set POSTCODEbutton = inputform.Item(2)
POSTCODEbutton.Click
Do While ie.ReadyState <> 4 Or ie.Busy = True
DoEvents
Loop
Application.Wait Now + TimeValue("00:00:05") 'force a 5 second wait to give the webpage more time to calculate
Set Postcodebox3 = inputform.Item(5)
Crow = Postcodebox3.Value
Set Postcodebox4 = inputform.Item(6)
Land = Postcodebox4.Value
Cells(Xrow, Ycol + 2) = Crow
Cells(Xrow, Ycol + 3) = Land
' check for 0 result or duplicate distances (presumably caused by website too slow)
intProblems = 0
If Cells(Xrow, Ycol + 2) = 0 Then intProblems = intProblems + 1
If Cells(Xrow, Ycol + 3) = 0 Then intProblems = intProblems + 1
If Cells(Xrow, Ycol + 2) = Cells(Xrow - 1, Ycol + 2) Then intProblems = intProblems + 1
If Cells(Xrow, Ycol + 3) = Cells(Xrow - 1, Ycol + 3) Then intProblems = intProblems + 1
If intProblems > 0 Then Xrow = Xrow - 1
Xrow = Xrow + 1
Loop
End With
ie.Quit
MsgBox "Finished. However...." & vbCr & vbCr & _
" Despite having delays coded to wait for the website to calculate, this macro sometimes returns the same distance for multiple postcode pairs." & vbCr & vbCr & _
"Review the results and validate any duplicate scores."
End Sub





So I have 2 questions:
1) Could somebody please help fix the above code?
(If someone also wanted to tidy/improve the code, or clarify each variable types I would also be very grateful)
2) Does anyone have a similar/better/international solution using Google Maps?


Thank you

 

[Taul]

Hi,
I can't troubleshoot your code but I can offer a Google maps alternative.

Excel 2010

	A	B	C	D

<tbody>
[TD="align: center"]1[/TD]
[TD="align: center"]Start[/TD]
[TD="align: center"]Finish[/TD]
[TD="align: center"]Km[/TD]
[TD="align: center"]Miles[/TD]

[TD="align: center"]2[/TD]
[TD="align: center"]SW1A 1AA[/TD]
[TD="align: center"]SW1A 2AA[/TD]
[TD="align: center"]1.17[/TD]
[TD="align: center"]0.73[/TD]

[TD="align: center"]3[/TD]
[TD="align: center"]B4 7XG[/TD]
[TD="align: center"]M16 0RA[/TD]
[TD="align: center"]138.68[/TD]
[TD="align: center"]86.17[/TD]

[TD="align: center"]4[/TD]
[TD="align: center"]WC2N 5DN[/TD]
[TD="align: center"]N7 8TT[/TD]
[TD="align: center"]5[/TD]
[TD="align: center"]3.11[/TD]

[TD="align: center"]5[/TD]
[TD="align: center"]NE9 6AA[/TD]
[TD="align: center"]NE8 4JB[/TD]
[TD="align: center"]2.07[/TD]
[TD="align: center"]1.29[/TD]

</tbody>

Sheet1​

formula in cell C2

=ROUND(G_Distance(A2,B2),2)

Formula in cell D2

=ROUND(C2*0.621371192,2)

Add this to a standard module

Function G_DISTANCE(Origin As String, Destination As String) As Double
Dim myRequest As XMLHTTP60
Dim myDomDoc As DOMDocument60
Dim distanceNode As IXMLDOMNode
    G_DISTANCE = 0
    On Error GoTo exitRoute
    Origin = Replace(Origin, " ", "%20")
    Destination = Replace(Destination, " ", "%20")
    Set myRequest = New XMLHTTP60
    myRequest.Open "GET", "http://maps.googleapis.com/maps/api/directions/xml?origin=" _
        & Origin & "&destination=" & Destination & "&sensor=false", False
    myRequest.send
    Set myDomDoc = New DOMDocument60
    myDomDoc.LoadXML myRequest.responseText
    Set distanceNode = myDomDoc.SelectSingleNode("//leg/distance/value")
    If Not distanceNode Is Nothing Then G_DISTANCE = distanceNode.Text / 1000
exitRoute:
    Set distanceNode = Nothing
    Set myDomDoc = Nothing
    Set myRequest = Nothing
End Function

 

[Taul]

Hi,
I notice you are from Holmfirth, isn't that where they filmed "Last of the Summer Wine"?

Paul.

 

[mwperkins]

Paul,
many thanks for the google maps version - just what I needed.

Yes - Last of the summer wine was filmed in and around Holmfirth. Actually, the tour bus passes my house.....but I haven't seen any old men in a bath tub for a while

 

[tommymac]

Hi,

Been trying Taul's solution but I can't seem to get it to work could someone please provide some guidance.

Getting the #NAME? error in cell C2.


Kind Regards,

 

[Stiuart_W]

You probably need to set the Microsoft XML reference

https://msdn.microsoft.com/en-us/library/ms763701(v=vs.85).aspx

 

[Kyle123]

It's also worth noting that this is a breach of the google T&Cs, they also rate limit the service, so expect it to stop working at any time

You can use the service from bing that has no such restriction - I wrote a post on it here:Getting Distances and DriveTimes

 

[tommymac]

You probably need to set the Microsoft XML reference

https://msdn.microsoft.com/en-us/library/ms763701(v=vs.85).aspx

Thanks got it to work on my personal laptop (excel 2016) but can't get it to work on my work laptop (excel 2013)

 

[Toonhammer]

Hi
I am sorry to be cheeky but I cant get this to work in Excel 2016, and I am not 100% sure of what I am doing when creating a module. Do I need to make any amendments for my sheet? or do I just insert module form the insert list? Or could you send me a copy of your sheet?

 

[mikeymay]

Fantastic bit of code!

Is it possible to get the driving time as per the output from google maps as well?


Thanks