VBA: MapPoint Macro Fails When More Than One Error

[nickshep85]

I have the below code which looks at a list of postcodes that I have in my Excel (2003) sheet, plots them one by one on a MapPoint Map and then tells me the nearest Item to that postcode. It is worth mentioning that I have removed any pre-defined items, such as restaurants and train stations, so that the only items on the Map are my own Pushpins.

I have built in an On Error line to skip any rows where MapPoint (2006) cannot find the postcode, however, I have noticed that this only works if there is only one error in the list of postcodes. If I have more than one error then the Macro will fail.

Can someone please help me out here as I cannot figure out why this keeps failing on me if there are two or more errors.

Thanks in advance,

Private Const TotCentre = 3

Sub FindNearbyPlaces()

'Dim objApp As New MapPoint.Application
Dim objMap As MapPoint.Map
Dim objNearby As MapPoint.Waypoint
Dim objLoc1 As MapPoint.Location
Dim sent As MapPoint.Location
Dim Centre As String
Dim NumCentre, NumCol, Itm  As Integer


Application.ScreenUpdating = False

Set objApp = CreateObject("Mappoint.Application.EU.13")
objApp.Visible = False
Set objMap = objApp.OpenMap("C:\Program Files\Microsoft MapPoint Europe\Centres By Type.ptm", False)
'objApp.UserControl = True

Sheets("RUN").Columns("B:J").Select
Selection.ClearContents
Sheets("RUN").Cells(1, 1).Select

'Insert Column Headers
Sheets("RUN").Cells(1, 2).Value = "Nearest Centre"
Sheets("RUN").Cells(1, 3).Value = "Centre Type"
Sheets("RUN").Cells(1, 4).Value = "Centre Code"
Sheets("RUN").Cells(1, 5).Value = "2nd Nearest Centre"
Sheets("RUN").Cells(1, 6).Value = "Centre Type"
Sheets("RUN").Cells(1, 7).Value = "Centre Code"
Sheets("RUN").Cells(1, 8).Value = "3rd Nearest Centre"
Sheets("RUN").Cells(1, 9).Value = "Centre Type"
Sheets("RUN").Cells(1, 10).Value = "Centre Code"

nreadrow = 2


Do While Sheets("RUN").Cells(nreadrow, 1) <> ""
On Error GoTo Skip
NumCol = 2

'Locate Start Point
Itm = 1
Set objLoc1 = objMap.FindResults(Sheets("RUN").Cells(nreadrow, 1)).Item(Itm)
For NumCentre = 1 To TotCentre

'Find 3 Nearest Centres Up To 50 Miles from Location & Show Results In Spreadsheet

Sheets("RUN").Cells(nreadrow, NumCol) = objLoc1.FindNearby(50).Item(Itm).Name
Centre = Sheets("RUN").Cells(nreadrow, NumCol)
Sheets("RUN").Cells(nreadrow, NumCol + 1).FormulaR1C1 = "=VLOOKUP(" & Chr(34) & Centre & Chr(34) & ",LOOKUP!C1:C12,6,0)"
Sheets("RUN").Cells(nreadrow, NumCol + 2).FormulaR1C1 = "=VLOOKUP(" & Chr(34) & Centre & Chr(34) & ",LOOKUP!C1:C12,12,0)"
NumCol = NumCol + 3
Itm = Itm + 1

'Sheets("RUN").Cells(nreadrow, 5) = objLoc1.FindNearby(50).Item(2).Name
'Centre 2 = Sheets("RUN").Cells(nreadrow, 5)
'Sheets("RUN").Cells(nreadrow, 8) = objLoc1.FindNearby(50).Item(3).Name
'Centre 3 = Sheets("RUN").Cells(nreadrow, 8)

Next

Skip:
nreadrow = nreadrow + 1
Loop

objApp.Quit

    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.Goto Reference:="R1C1"
    Application.CutCopyMode = False
Cells(1, 1).Select

Application.ScreenUpdating = True
MsgBox "Event Complete"


End Sub

 

[nickshep85]

Can anyone help with this?

Looking at other forum posts, I think it maybe to do with the On Error Goto that I have in the code. The first time there is an error it goes to Skip: but when there is a second error, the code crashes.

Could it be the fact that I have my On Error Goto within a Do/Loop?

Simplified Code below:

Do While Sheets("RUN").Cells(nreadrow, 1) <> "" 
On Error GoTo Skip
'Find Location and Populate Results in Sheet
Next
Skip:
nreadrow = nreadrow+1
Loop