PDA

View Full Version : macro for calculating from one zip code to multiple zipcodes



shahdelsol
08-14-2009, 05:38 PM
I am trying to find out the distance from one zip code to 600 other zip codes. I like to know if there is a simple code for it instead of typing 600 lines of code? Below is the code I have, as you see the cell increases by one and as I said this goes up to 600. Can one code do them all instead of repeating for 600 times?
Set oApp = CreateObject("MapPoint.Application.NA.16")
oApp.Visible = True
Set objMap = oApp.NewMap
Set objRoute = objMap.ActiveRoute

szZip1 = Worksheets("Sheet1").Cells(1, 1)
szZip2 = Worksheets("Sheet1").Cells(2, 1)

'Add route stops and calculate the route
objRoute.Waypoints.Add objMap.FindResults(szZip1).Item(1)
objRoute.Waypoints.Add objMap.FindResults(szZip2).Item(1)
objRoute.Calculate

Worksheets("Sheet1").Cells(2, 2) = objRoute.Distance

objMap.Saved = True


szZip1 = Worksheets("Sheet1").Cells(1, 1)
szZip2 = Worksheets("Sheet1").Cells(3, 1)

'Add route stops and calculate the route
objRoute.Waypoints.Add objMap.FindResults(szZip1).Item(1)
objRoute.Waypoints.Add objMap.FindResults(szZip2).Item(1)
objRoute.Calculate

Worksheets("Sheet1").Cells(3, 2) = objRoute.Distance



objMap.Saved = True

szZip1 = Worksheets("Sheet1").Cells(1, 1)
szZip2 = Worksheets("Sheet1").Cells(4, 1)

'Add route stops and calculate the route
objRoute.Waypoints.Add objMap.FindResults(szZip1).Item(1)
objRoute.Waypoints.Add objMap.FindResults(szZip2).Item(1)
objRoute.Calculate

Worksheets("Sheet1").Cells(4, 2) = objRoute.Distance

and so on............

Eric Frost
08-15-2009, 12:39 PM
There is a batch tool for calculating the distance between zip codes that is part of the "MapPoint Power Tools" spreadsheet --

http://www.mapforums.com/mappoint-power-tools-spreadsheet-8080.html

Here's a direct link to the screenshot for that tool --

http://www.mapforums.com/attachments/111d1219327156-mappoint-power-tools-spreadsheet-distance.gif

I think this does what you want?

$19.95 gets you three months access to downloads in this section.

hope this helps. :balloon2:

Eric

davidb
08-15-2009, 02:30 PM
Also wouldn't it be possible just to use a Do Loop eg




szZip1 = Worksheets("Sheet1").Cells(1, 1)
NRow=2

Do
szZip2 = Worksheets("Sheet1").Cells(NRow, 1)
'Add route stops and calculate the route
objRoute.Waypoints.Add objMap.FindResults(szZip1).Item(1)
objRoute.Waypoints.Add objMap.FindResults(szZip2).Item(1)
objRoute.Calculate
Worksheets("Sheet1").Cells(3, 2) = objRoute.Distance
objRoute.Clear
NRow=NRow+1
Loop While Worksheets(“Sheet1”).Cells(NRow,1) <> “”

shahdelsol
08-15-2009, 04:43 PM
Also wouldn't it be possible just to use a Do Loop eg




szZip1 = Worksheets("Sheet1").Cells(1, 1)
NRow=2

Do
szZip2 = Worksheets("Sheet1").Cells(NRow, 1)
'Add route stops and calculate the route
objRoute.Waypoints.Add objMap.FindResults(szZip1).Item(1)
objRoute.Waypoints.Add objMap.FindResults(szZip2).Item(1)
objRoute.Calculate
Worksheets("Sheet1").Cells(3, 2) = objRoute.Distance
objRoute.Clear
NRow=NRow+1
Loop While Worksheets(“Sheet1”).Cells(NRow,1) <> “”



Thanks for responding but I get an errror at the last line of your code. Am I doing anything wrong here?

davidb
08-16-2009, 03:19 AM
The symbol for quotation marks in the last line isn't right. Replace them by the normal keyboard symbol.

davidb
08-16-2009, 03:22 AM
Also the line to ouput the result should read

Worksheets("Sheet1").Cells(NRow, 2) = objRoute.Distance

shahdelsol
08-16-2009, 04:37 AM
Also the line to ouput the result should read

Worksheets("Sheet1").Cells(NRow, 2) = objRoute.Distance
Yes David, I did change quotation mark but still the code stops at last line. Any Idea?

davidb
08-16-2009, 05:53 AM
what's the error message and what's the format of your input data?

shahdelsol
08-16-2009, 05:57 AM
what's the error message and what's the format of your input data?
The code stops at last line and doesnot continue and mappoint only calculate the first two zips and stay open with debug and end dialog box. something missing at last line I think and the format is .xlsm

davidb
08-16-2009, 06:15 AM
I just tried the following code and it worked for me.



Private Sub CommandButton1_Click()

Set oApp = CreateObject("MapPoint.Application.NA.16")
oApp.Visible = True
Set objMap = oApp.NewMap
Set objRoute = objMap.ActiveRoute
szZip1 = Worksheets("Sheet1").Cells(1, 1)
NRow = 2

Do
szZip2 = Worksheets("Sheet1").Cells(NRow, 1)
'Add route stops and calculate the route
objRoute.Waypoints.Add objMap.FindResults(szZip1).Item(1)
objRoute.Waypoints.Add objMap.FindResults(szZip2).Item(1)
objRoute.Calculate
Worksheets("Sheet1").Cells(NRow, 2) = objRoute.Distance
objRoute.Clear
NRow = NRow + 1
Loop While Worksheets("Sheet1").Cells(NRow, 1) <> ""

End Sub


Please note that there is no error handling built into the code. so in particular all your zip codes have to be valid or the program will fail. Also based on your first post I've assumed that the first cell of column A contains your first 'origin' zip and that all the other zips are in the same column without any blank cells. The program ends when it finds a blank cell in that column.

shahdelsol
08-16-2009, 06:54 AM
I just tried the following code and it worked for me.



Private Sub CommandButton1_Click()

Set oApp = CreateObject("MapPoint.Application.NA.16")
oApp.Visible = True
Set objMap = oApp.NewMap
Set objRoute = objMap.ActiveRoute
szZip1 = Worksheets("Sheet1").Cells(1, 1)
NRow = 2

Do
szZip2 = Worksheets("Sheet1").Cells(NRow, 1)
'Add route stops and calculate the route
objRoute.Waypoints.Add objMap.FindResults(szZip1).Item(1)
objRoute.Waypoints.Add objMap.FindResults(szZip2).Item(1)
objRoute.Calculate
Worksheets("Sheet1").Cells(NRow, 2) = objRoute.Distance
objRoute.Clear
NRow = NRow + 1
Loop While Worksheets("Sheet1").Cells(NRow, 1) <> ""

End Sub


Please note that there is no error handling built into the code. so in particular all your zip codes have to be valid or the program will fail. Also based on your first post I've assumed that the first cell of column A contains your first 'origin' zip and that all the other zips are in the same column without any blank cells. The program ends when it finds a blank cell in that column.
Thanks so much it is working now. If you look at your original code there was one line different and that was the problem. now I have one more question if you don't mind: If I want to change my primary zip cell to (1,3) and second zip to (3,1) and result to (3,3) and rest of zip underneath (3,1) just like before, how would be new code look like?

PROFIT100 Consulting
07-27-2010, 01:15 AM
Distances between Postcodes, Cities, Adresses you can calculate very easily by using the MapPoint Tool "IC-DistanceCalc (http://www.mappoint2010.info/html/ic-tools_download.html)", (Excel AddIn).
You can download the tool for free. :flowers:
If you register (http://seminarzentrum-darmstadt.de/tinc?key=4aifjtsv&formname=USA), we will send you a 1 year upgrade to PLUS-Version (unlimited) for free plus an Excel-sheet with all USA-Postcodes with Longitudes ans Altitudes.

Kind regards
Manfred Sündorf

Email: ms@profit100.de