PDA

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

shahdelsol
08-14-2009, 06: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.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.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.Calculate

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

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

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

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

I think this does what you want?

hope this helps. :balloon2:

Eric

davidb
08-15-2009, 03: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.Calculate
Worksheets("Sheet1").Cells(3, 2) = objRoute.Distance
objRoute.Clear
NRow=NRow+1
Loop While Worksheets(“Sheet1”).Cells(NRow,1) <> “”

shahdelsol
08-15-2009, 05: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.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, 04: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, 04:22 AM
Also the line to ouput the result should read

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

shahdelsol
08-16-2009, 05: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, 06:53 AM
what's the error message and what's the format of your input data?

shahdelsol
08-16-2009, 06: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, 07: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.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, 07: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.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, 02:15 AM