Source code
===========
Module 1:
---------
Option Explicit

Sub SelectedLocation(ByVal cardName As String, ByVal ArriveOn As String, ByVal targetRow As Long, ByVal targetCol As Long)
    Dim aHourMin() As String
    Dim strHour As String
    Dim strMinute As String
    Dim ArriveInMin As String
    
    ActiveSheet.Cells(targetRow + 1, 2).Value = cardName
    ActiveSheet.Cells(targetRow, targetCol).Value = cardName
    'ActiveSheet.Cells(targetRow, targetCol).Value = cardName
    
    ' Adding up the time for "Arrive On"
    ' The format pass to here is 1 hour 58 minutes
    strHour = "0"
    strMinute = ""
    
    If InStr(LCase(ArriveOn), "hour") > 0 Then
        aHourMin = Split(LCase(ArriveOn), "hour")
        strHour = aHourMin(0)
        strMinute = Split(aHourMin(1), "minute")(0)
    Else
        aHourMin = Split(LCase(ArriveOn), "minute")
        strMinute = aHourMin(0)
    End If
    
    ArriveInMin = strHour & ":" & strMinute
    
    'ActiveSheet.Cells(targetRow, 14).Value = ArriveOn
    'ActiveSheet.Cells(targetRow, 16).Value = ArriveInMin
    
    ActiveSheet.Cells(targetRow, 5).Value = CDate(ActiveSheet.Cells(targetRow, 3).Value) + CDate(ArriveInMin)     ' In time format
    ActiveSheet.Cells(targetRow + 1, 3).Value = ActiveSheet.Cells(targetRow, 5).Value
End Sub

Sheet1 (Start):
---------------
Option Explicit

Const MAPPINGTRIP As String = "MappingTrip"
Const APIKey As String = "DjTSij834HoAGE1NFdBn9fQv3ZTwfEmQ"
Const STATICMAP As String = "https://www.mapquestapi.com/staticmap/v5/map?"
Const ROUTEMATRIX As String = "http://www.mapquestapi.com/directions/v2/routematrix?allToAll=true"
Const cardWidth = 200
Const cardHeight = 100
Const cardSeparator = 5
Const cardWithText = 50
Dim totalCard As Integer

Private Sub DrawDestinationShape(ByVal cellTarget As String, ByVal destinationRow As Integer, ByVal destinationCol As Integer)
    Dim shapeRectangle As Shape
    Dim shapeTextBox As Shape
    Dim totalRow As Integer
    Dim iRow As Integer
    Dim strShapeName As String
    Dim intLeft As Integer
    Dim intTop As Integer
    Dim shp As Shape
    Dim wsCard As Worksheet
    Dim sheetName As String
    Dim shapeTextTitle As String
    Dim shapeTextBody As String
    Dim allLength As Integer
    Dim mapCity As String
    Dim mapCityDest As String
    Dim returnDistance As String
    Dim mapDistance As String
    Dim strMapTime As String
    Dim topBeginPos As Integer
    Dim gAPIMapUrl As String
    Dim iMappingTrip As Integer
    Dim intDestRow As Integer
    Dim intDestCol As Integer

    'Dim Auth As New GoogleAuthenticator

    ' If value change, let's remove the shape(s) first
    For Each shp In ActiveSheet.Shapes
        If Left(shp.Name, 11) = MAPPINGTRIP Then
            shp.Delete
        End If
    Next shp
    
    Application.ScreenUpdating = True
    
    totalCard = 0
    intDestRow = destinationRow
    intDestCol = destinationCol
    topBeginPos = ActiveSheet.Cells(intDestRow + 1, intDestCol).Top
    
    mapCity = Replace(RTrim(LTrim(ActiveSheet.Cells(intDestRow, 2).Value)), " ", "+")
    mapCityDest = RTrim(LTrim(ActiveSheet.Cells(intDestRow, intDestCol).Value))
    mapCityDest = Replace(mapCityDest, " ", "+")        'Map quest seem better with a "+" instead of space
    gAPIMapUrl = STATICMAP & "start=" & mapCity & "&end=" & mapCityDest & "&size=600,400@2x&key=" & APIKey
    'ActiveSheet.Cells(intDestRow, 17).Value = gAPIMapUrl
    
    'iMappingTrip = iMappingTrip + 1
    iMappingTrip = 1
    intLeft = ActiveSheet.Cells(intDestRow, intDestCol + 4).Left + cardSeparator  'Me.Columns(ActiveCell.Column + 1).Left + cardSeparator
    intTop = topBeginPos + (totalCard * (100 + cardSeparator))

    strShapeName = MAPPINGTRIP & "Map" & iMappingTrip
    Set shapeRectangle = ActiveSheet.Shapes.AddShape(msoShapeRectangle, intLeft, intTop, cardWidth, cardHeight)
    shapeRectangle.Name = strShapeName
    
    ' If different country, use routeArc is better
    ' Refer to https://developer.mapquest.com/documentation/static-map-api/v5/map/#formatting-locations
    ' One to many route matrix
    ' http://www.mapquestapi.com/directions/v2/routematrix?key=[...]&ambiguities=ignore&doReverseGeocode=false&outFormat=xml&routeType=fastest&unit=k&allToAll=false&manyToOne=true&from=Prag%201%20Tschechien&to=01067%20Dresden&to=90471%20Nuernberg&to=48143%20Muenster
    ' http://www.mapquestapi.com/directions/v2/routematrix?key=[...]&ambiguities=ignore&doReverseGeocode=false&outFormat=xml&json={options:{routeType:"fastest",unit:"k",allToAll:"false",oneToMany:"true"},locations:["35.6279341,140.1614732","35.6533836,140.0298335","35.6466112,140.0397265","35.6498048,140.0341671"]}
    shapeRectangle.Fill.userPicture gAPIMapUrl
    ' For error handling, check the return code of <response><info><statusCode>xxx</statusCode>
        
    returnDistance = OnlineDistanceTime(mapCity, mapCityDest)
    'returnDistance = GetDistanceAndTime(mapCity, mapCityDest)
    'ActiveSheet.Cells(21, 13).Value = "Text = " & returnDistance & ". Len: " & Len(returnDistance)
    mapDistance = Split(returnDistance, "-_-")(0)
    strMapTime = Split(returnDistance, "-_-")(1)
    
    With ActiveSheet.Shapes(strShapeName).Select
        ActiveSheet.Cells(intDestRow, intDestCol + 2).Value = mapDistance
        ActiveSheet.Cells(intDestRow, intDestCol + 3).Value = strMapTime
        
        Selection.Characters.Text = "Distance: " & mapDistance & vbCrLf & "Time: " & strMapTime
        
        Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 128, 128)
        'RGB(51, 102, 255) RGB(0, 128, 128)  'RGB(51, 153, 102) 'RGB(128, 128, 0)   ' Some colors to play around
        Selection.ShapeRange.Fill.Transparency = 0.5
        Selection.ShapeRange.Line.Weight = 0.1
        Selection.ShapeRange.Line.Style = msoLineSingle
        Selection.ShapeRange.Line.Visible = msoTrue
        Selection.ShapeRange.Line.ForeColor.SchemeColor = 17
        Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
        
        allLength = Len(shapeTextTitle) + Len(shapeTextBody)
                            
        With Selection.Characters(Start:=1, Length:=allLength).Font
            .Name = "Arial"
            .FontStyle = "Regular"
            '.Color = RGB(255, 255, 255)
            .Size = 10
            .Shadow = True
        End With
    End With
    
    With ActiveSheet.Shapes(strShapeName).Shadow
        .Visible = True
        '.ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0.8
    End With
    
    totalCard = 1
    
    ' Get the photo to the exact location
    LocationDetails Replace(mapCity, "+", " "), Replace(mapCityDest, "+", " "), True, intDestRow, intDestCol
    
    ' Get some photos for the same the city
    LocationDetails Replace(mapCity, "+", " "), Replace(mapCityDest, "+", " "), False, intDestRow, intDestCol
    
    ' Weird problem after copy and paste code
    'ShapeMacroLinkAll_RemoveWorkbookRef
    
    ActiveSheet.Cells(intDestRow, intDestCol).Select
End Sub

Function OnlineDistanceTime(ByVal textFrom As String, ByVal textTo As String) As String
    Dim returnValue As String
    Dim strMapTime As String
    Dim strMapDistance As String
    Dim returnDistance As String
    Dim textTime As String
    Dim aDistance() As String
    Dim aMapDistance() As String
    Dim gAPIMapUrl As String
    Dim mapDistance As Double
    Dim mapTime As Double
    Dim intHour As Double
    Dim intMinute As Integer

    'On Error GoTo Error_handler:
    
    ' Get the different between 2 points.
    ' MapQuest route matrix limits
    '    A One to Many route matrix call can handle up to 100 locations.
    '    A Many to One matrix call can handle up to 50 locations.
    '    An all to all route matrix call can handle up to 25 locations.
    '    More Info: https://developer.mapquest.com/documentation/directions-api/route-matrix/post/
    '    e.g. Jason: http://www.mapquestapi.com/directions/v2/routematrix?from=tokyo&to=chiba&key=key
    '       XML : http://www.mapquestapi.com/directions/v2/routematrix?informat=xml&outformat=xml&from=penang&to=hong+20kong&key=DjTSij834HoAGE1NFdBn9fQv3ZTwfEmQ
    '       https://www.mapquestapi.com/staticmap/v5/map?start=New+York,NY&end=London,England&routeArc=true&size=@2x&key=KEY
    'gAPIMapUrl = "http://www.mapquestapi.com/directions/v2/routematrix?allToAll=true&from=" & strFromCoordinate & "&to=" & strToCoordinate & "&key=" & APIKey
    gAPIMapUrl = ROUTEMATRIX & "&from=" & textFrom & "&to=" & textTo & "&key=" & APIKey
    'MsgBox "map distance url: " & gAPIMapUrl
    
    returnDistance = getDistance(gAPIMapUrl)
    returnDistance = Replace(returnDistance, "[", "")
    returnDistance = Replace(returnDistance, "]", "")

    aDistance = Split(returnDistance, "-_-")    '0,24.293,24.403,0-_-0,1790,1798,0
    
    ' Get the distance in km
    aMapDistance = Split(aDistance(0), ",")        '0,24.293,24.403,0
    mapDistance = CDbl(aMapDistance(1)) + CDbl(aMapDistance(2))
    'mapDistance = mapDistance / 2
    mapDistance = Round(mapDistance, 1)
    
    strMapDistance = mapDistance & " km"
    
    ' Get the time minutes or hours + minutes
    aMapDistance = Split(aDistance(1), ",")         '0,1790,1798,0
    mapTime = CDbl(aMapDistance(1)) + CDbl(aMapDistance(2))
    mapTime = mapTime / 2
    mapTime = mapTime / 60
    mapTime = Round(mapTime, 0)
        
    If mapTime > 60 Then
        'intHour = Split((CDbl(aMapDistance(1)) + CDbl(aMapDistance(2)) / 2) / 60 / 60, ".")(0)
        intHour = CDbl(aMapDistance(1)) + CDbl(aMapDistance(2))
        intHour = intHour / 2
        intHour = intHour / 3600
        intHour = Split(intHour, ".")(0)
        intMinute = CDbl(CStr("0." & Split((CDbl(aMapDistance(1)) + CDbl(aMapDistance(2)) / 2) / 60 / 60, ".")(1))) * 60
        
        If intHour > 1 Then
            strMapTime = CStr(intHour) & " hours"
        Else
            strMapTime = CStr(intHour) & " hour"
        End If
        
        strMapTime = strMapTime & " " & CStr(intMinute) & " minutes"
    Else
        strMapTime = CStr(mapTime) & " minutes"
    End If
    
    returnValue = strMapDistance & "-_-" & strMapTime
    OnlineDistanceTime = returnValue
End Function

Function getDistance(urlAPIMapUrl) As String
    Dim xmlhttp As New MSXML2.XMLHTTP60
    Dim xmlresponse As New DOMDocument60
    Dim retValue As String
    Dim objJason As Object
    Dim objJasonItem As Variant
    Dim i As Integer
    Dim strDistance As String
    Dim strTime As String
    
    'On Error Resume Next
    'ActiveSheet.Cells(12, 13).Value = urlAPIMapUrl
    
    retValue = "Error!"
        
    xmlhttp.Open "GET", urlAPIMapUrl, False
    xmlhttp.setRequestHeader "Content-Type", "application/json"
    xmlhttp.send

    'ActiveSheet.Cells(13, 18).Value = xmlhttp.responseText
    
    Set objJason = JsonConverter.ParseJson(xmlhttp.responseText)
    
    i = 0
    For Each objJasonItem In objJason.Keys
        If LCase(Trim(objJasonItem)) = "distance" Then
            strDistance = Replace(JsonConverter.ConvertToJson(objJason(objJasonItem)), """", "")
        End If
        If LCase(Trim(objJasonItem)) = "time" Then
            strTime = Replace(JsonConverter.ConvertToJson(objJason(objJasonItem)), """", "")
        End If
        
        ' There are 6 keys found from the JASON
        'ActiveSheet.Cells(13 + i, 12).Value = i
        'ActiveSheet.Cells(13 + i, 13).Value = objJasonItem
        'ActiveSheet.Cells(13 + i, 14).Value = Replace(JsonConverter.ConvertToJson(objJason(objJasonItem)), """", "")
        i = i + 1
    Next
    
    If Len(strDistance) = 0 Or Len(strTime) = 0 Then
        retValue = "ERROR!"
    Else
        retValue = strDistance & "-_-" & strTime
    End If
    
    getDistance = retValue

    Set objJason = Nothing
    Set xmlresponse = Nothing
    Set xmlhttp = Nothing
End Function

Sub LocationDetails(ByVal sourceLocation As String, ByVal targetLocation As String, ByVal NoNeedSameCity As Boolean, ByVal targetRow As Long, ByVal targetCol As Long)
    Dim shapeRectangle As Shape
    Dim shapeTextBox As Shape
    Dim totalRow As Integer
    Dim iRow As Integer
    Dim strShapeName As String
    Dim intLeft As Integer
    Dim intTop As Integer
    Dim wsCard As Worksheet
    Dim sheetName As String
    Dim iCard As Integer
    Dim bFoundLocation As Boolean
    Dim shapeTextTitle As String
    Dim shapeTextBody As String
    Dim allLength As Integer
    Dim mapCityDest As String
    Dim returnDistance As String
    Dim mapDistance As String
    Dim strMapTime As String
    Dim topBeginPos As Integer
    Dim iMappingTrip As Integer
    Dim wsLocation As Worksheet
    Dim iLocation As Integer
    Dim sourceLocationLocation As String
    Dim userPicture As String

    'totalCard = 1
    topBeginPos = ActiveSheet.Cells(targetRow + 1, targetCol).Top
    
    For iCard = 1 To ActiveWorkbook.Worksheets.Count - 1
        Set wsCard = ActiveWorkbook.Worksheets(iCard)
        sheetName = wsCard.Name
        
        If LCase(sheetName) = "tokyo" Then
            totalRow = wsCard.Range("B1").End(xlDown).Row    ' Find totalRow. Assume all are pointing to "B1"
            iMappingTrip = 0
            intLeft = 200
            
            For iRow = 2 To totalRow
                bFoundLocation = False
                
                If Not NoNeedSameCity Then
                    'MsgBox "Need same city"
                    ' Finding the source's location for one time only
                    If iRow = 2 Then
                        Set wsLocation = ActiveWorkbook.Worksheets("Location")
                    
                        For iLocation = 2 To wsLocation.Range("C1").End(xlDown).Row
                            'MsgBox "Should only run once"
                            If wsLocation.Cells(iLocation, 2).Value = targetLocation Then
                                sourceLocationLocation = wsLocation.Cells(iLocation, 3).Value
                                Exit For
                            End If
                        Next
                        
                        Set wsLocation = Nothing
                    End If
                    
                    'MsgBox "current location: " & wsCard.Cells(iRow, 3).Value & " | source location: " & sourceLocationLocation _
                    '    & vbCrLf & "current tokyo place: " & wsCard.Cells(iRow, 2).Value & " | target place: " & targetLocation
                        
                    If LCase(wsCard.Cells(iRow, 3).Value) = LCase(sourceLocationLocation) Then
                        If LCase(targetLocation) <> LCase(wsCard.Cells(iRow, 2).Value) Then
                            'MsgBox "Found different place but same tokyo"
                            
                            bFoundLocation = True
                        End If
                    End If
                Else
                    'MsgBox "No need same city"
                    If LCase(wsCard.Cells(iRow, 2).Value) = LCase(targetLocation) Then
                        bFoundLocation = True
                    End If
                End If
            
                If bFoundLocation Then
                    intTop = topBeginPos + (totalCard * (100 + cardSeparator))
                    
                    If totalCard > 1 Then
                        intTop = intTop + ((totalCard - 1) * cardWithText)
                    End If
                    
                    With ActiveSheet
                        iMappingTrip = iMappingTrip + 1
                        
                        If iMappingTrip = 1 Then
                            intLeft = ActiveSheet.Cells(targetRow, targetCol + 4).Left + 5
                        Else
                            If iMappingTrip > 1 Then
                                intLeft = intLeft + 205
                            End If
                        End If
                        
                        ' Giving the shape name. Make sure the same city shape got something to differentiate it.
                        strShapeName = MAPPINGTRIP & sheetName
                        
                        If Not NoNeedSameCity Then
                            strShapeName = strShapeName & "City"
                        End If
                        
                        strShapeName = strShapeName & iMappingTrip
                        
                        Set shapeRectangle = .Shapes.AddShape(msoShapeRectangle, intLeft, intTop, cardWidth, cardHeight)
                        shapeRectangle.Name = strShapeName
                        
                        '----- Let's add in distance/time to ease the visiting
                        mapCityDest = wsCard.Cells(iRow, 2).Value
                        'MsgBox "Dest: " & mapCityDest
                        
                        returnDistance = OnlineDistanceTime(Replace(sourceLocation, " ", "+"), Replace(mapCityDest, " ", "+"))
                        
                        mapDistance = Split(returnDistance, "-_-")(0)
                        strMapTime = Split(returnDistance, "-_-")(1)
                        '-----------
                        
                        With shapeRectangle
                             .OnAction = "'SelectedLocation """ & wsCard.Cells(iRow, 2).Value & """, """ & strMapTime & """, " & targetRow & ", " & targetCol & "'"
                             '.OnAction = "'SelectedCard """ & wsCard.Cells(iRow, 2).Value & """, " & targetRow & ", " & targetCol & "'"
                        End With

                        With .Shapes(strShapeName).Select
                            shapeTextBody = wsCard.Cells(iRow, 4).Value
                            shapeTextTitle = sourceLocation & " - " & mapCityDest
                            
                            Selection.Characters.Text = shapeTextTitle & vbCrLf & "Distance: " & mapDistance & " / " & strMapTime
                            Selection.Characters(1, Len(shapeTextTitle)).Font.Bold = True
                            
                            allLength = Len(shapeTextTitle) + Len(shapeTextBody)
                                    
                            With Selection.Characters(Start:=1, Length:=allLength).Font
                                .Name = "Arial"
                                .FontStyle = "Regular"
                                '.Color = RGB(255, 255, 255)
                                .Size = 8
                                .Shadow = True
                            End With
                            
                            ' Show destination description below the picture
                            Set shapeTextBox = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, intLeft, intTop + 100, cardWidth, cardHeight - 50)
                            shapeTextBox.Name = MAPPINGTRIP & sheetName & "Text" & iMappingTrip
                            shapeTextBox.TextFrame.Characters.Text = shapeTextBody
                            shapeTextBox.TextFrame2.TextRange.Font.Name = "Arial"
                            shapeTextBox.TextFrame2.TextRange.Font.Size = 8
                            
                            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(51, 102, 255)
                            Selection.ShapeRange.Fill.Transparency = 0.5
                            Selection.ShapeRange.Line.Weight = 0.1
                            Selection.ShapeRange.Line.Style = msoLineSingle
                            Selection.ShapeRange.Line.Visible = msoTrue
                            Selection.ShapeRange.Line.ForeColor.SchemeColor = 17
                            Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
                        End With
                           
                        With ActiveSheet.Shapes(strShapeName).Shadow
                            .Visible = True
                            '.ForeColor.RGB = RGB(255, 0, 0)
                            .Transparency = 0.8
                        End With
                            
                        With ActiveSheet.Shapes(strShapeName).Fill
                            .Visible = msoTrue
                            
                            userPicture = ThisWorkbook.Path & "\picture\" & Replace(wsCard.Cells(iRow, 2).Value, " ", "_") & ".jpg"
                            
                            If FileExists(userPicture) Then
                                .userPicture userPicture
                            End If
                            
                            '.TextureTile = msoFalse
                            ActiveSheet.Shapes(strShapeName).Width = 200
                        End With
                    End With
                End If
                
                If bFoundLocation And NoNeedSameCity Then
                    Exit For
                End If
            Next
        End If
    
        If bFoundLocation Then
            totalCard = totalCard + 1
        '    Application.EnableEvents = True
        '    Application.Calculation = xlCalculationAutomatic
        '    Application.ScreenUpdating = True
        'Else
        '    Application.ScreenUpdating = False
        '    Application.EnableEvents = False
        '    Application.Calculation = xlCalculationManual
        End If
    Next
    
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Function FileExists(ByVal filename As String) As Boolean
    Dim returnValue As String
    
    returnValue = ""
    On Error Resume Next
    returnValue = Dir(filename)
    On Error GoTo 0
    
    If returnValue = "" Then
        FileExists = False
    Else
        FileExists = True
    End If
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Dim textTarget As String
    
    'On Error Resume Next
    
    If ActiveSheet.Name = "Start" Then      ' Only interested on start worksheet
        Set KeyCells = Range("D2:D10")
        
        If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
            'MsgBox ("Length > zero? " & Len(Target.Value))
            'Display something according to the destination selected
            If Len(ActiveSheet.Cells(Target.Row, Target.Column).Value) > 0 Then
                textTarget = Target.Value
                DrawDestinationShape textTarget, Target.Row, Target.Column
            End If
        End If
    End If
End Sub