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]

I can’t take credit for the code but you can take a look at the source at the link below. There are options to add features.
http://oco-carbon.com/coding/<wbr>google-excel-distance-<wbr>function/

As Kyle123 rightly says, it is in breach of the T&C’s but if you add a map to the spreadsheet it is within the T&C’s.
As I’m a naughty boy I leave off the map because it’s quicker but that’s just me.

 

[tecia88]

Can someone help me with this, I am a total novice but would be great to learn as I am doing a piece of work around relocation

 

[Taul]

Hi,
I don’t think this code works anymore unless you have a valid API key from Google. The API keys used to be free but now Google require a valid credit card in order to obtain the API key.
As I don’t currently have a key, I can’t tell if the code will still work or not.

I would suggest you try the code offered by Kyle123 in post #7, the most recent feedback is dated 2018, so that is encouraging.

Link here:-
Getting Distances and DriveTimes

good luck
Paul.