Calculate driving distance between postcodes

mwperkins

Board Regular
Joined
Oct 29, 2002
Messages
156
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
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Hi,
I can't troubleshoot your code but I can offer a Google maps alternative.

Excel 2010
ABCD
1StartFinishKmMiles
2SW1A 1AASW1A 2AA1.170.73
3B4 7XGM16 0RA138.6886.17
4WC2N 5DNN7 8TT53.11
5NE9 6AANE8 4JB2.071.29

<tbody>
</tbody>
Sheet1

formula in cell C2
Code:
=ROUND(G_Distance(A2,B2),2)

Formula in cell D2
Code:
=ROUND(C2*0.621371192,2)

Add this to a standard module

Code:
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
 
Upvote 0
Hi,
I notice you are from Holmfirth, isn't that where they filmed "Last of the Summer Wine"?

Paul.
 
Upvote 0
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 :)
 
Upvote 0
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,
 
Upvote 0
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
 
Upvote 0
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?
 
Upvote 0
Fantastic bit of code!

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


Thanks
 
Upvote 0

Forum statistics

Threads
1,213,494
Messages
6,113,988
Members
448,538
Latest member
alex78

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top