MapForums

Sub Measure_it()
    Dim objApp As Object 'MapPoint.Application
    Dim objMap As Object 'MapPoint.Map
    Dim objRoute As Object 'as MapPoint.Route
    Dim objLoc As Object 'MapPoint.Location
    Dim objLoc2 As Object 'MapPoint.Location
    Dim myAdd, myAdd2, myCity, myCity2, myState, myState2, myFind, myFind2 As String
    Dim myZip, myZip2, myRow As Integer
    number_rows = Cells(1, 11).Value + 1
    
On Error Resume Next
For myRow = 2 To number_rows
    myAdd = Cells(myRow, 2)     'Use the first column as the address info
    myCity = Cells(myRow, 3)        'Use the second column as the city info
    myState = Cells(myRow, 4)       'Use the third column as the state info
    myZip = Cells(myRow, 5)     'Use the fourth column as the zip info
    
    myAdd2 = Cells(myRow, 6)     'Use the first column as the address info
    myCity2 = Cells(myRow, 7)        'Use the second column as the city info
    myState2 = Cells(myRow, 8)       'Use the third column as the state info
    myZip2 = Cells(myRow, 9)     'Use the fourth column as the zip info
    
    'The first column on the spreadsheet is a blank used for the confirmation info below
    Cells(myRow, 1).Value = ""
    Cells(myRow, 10).Value = ""
    Cells(myRow, 1).Interior.ColorIndex = xlColorIndexNone  'Set background
    
    If Len(myAdd) < 2 Then Exit Sub 'If the address is less than 2 characters, exit
    If Len(myAdd2) < 2 Then Exit Sub 'If the address is less than 2 characters, exit
    Set objApp = CreateObject("Mappoint.Application")
    Set objMap = objApp.newMap      'Create the new map
    Set objRoute = objMap.activeRoute
    myFind = myAdd & "," & myCity & "," & myState   'Create the address string
    myFind2 = myAdd2 & "," & myCity2 & "," & myState2 'Create 2nd address string
    Set objLoc = objMap.Find(myFind)    'Find the new address
    Set objLoc2 = objMap.Find(myFind2)    'Find the new address
    objRoute.Waypoints.Add objLoc
    objRoute.Waypoints.Add objLoc2
    objRoute.Calculate
    Cells(myRow, 10) = objRoute.Distance

    If Not objLoc Is Nothing Then     'If found, start processing
        Cells(myRow, 1).Value = "Found!"    'Change 1st column to found
        Cells(myRow, 1).Interior.ColorIndex = 4 'Change color to Green
        Cells(myRow, 2).Select      'Reselect our address field
    Else
        Cells(myRow, 1).Value = "Not Found!"    'Didn't find the address
        Cells(myRow, 1).Interior.ColorIndex = 3 'Set color to red
    End If
    
    Set objLoc = Nothing
    Set objMap = Nothing
    Set objApp = Nothing
    Next
On Error GoTo 0
End Sub