Dijkstra's algorithm with VBA

Option Explicit
Option Base 1

Type Vertex
    c(3) As Double          ' coordinates
    radius As Double
    visited As Boolean
    neig(101) As Long
    nn As Long              ' number of neighbors
    tim As Double
    previous As Long
End Type
Dim vert() As Vertex, i%, j%, n%, vc#, vh#, ss()

Function ENormSq(x0#, y0#, z0#, x1#, y1#, z1#)      ' Euclidean norm
    ENormSq = (x1 - x0) ^ 2 + (y1 - y0) ^ 2 + (z1 - z0) ^ 2
End Function

Function LPDist(x1#, y1#, z1#, x2#, y2#, z2#, x#, y#, z#) As Double
Dim xn#, yn#, zn#, bot#, t#                  ' calculates distance between line and point
If x1 = x2 And y1 = y2 And z1 = z2 Then      ' line is a point
    xn = x1
    yn = y1
    zn = z1
Else                                        ' line is a line
    bot = ENormSq(x1, y1, z1, x2, y2, z2)
    t = ((x1 - x) * (x1 - x2) + (y1 - y) * (y1 - y2) + (z1 - z) * (z1 - z2)) / bot
    t = WorksheetFunction.Max(t, 0)
    t = WorksheetFunction.Min(t, 1)
    xn = x1 + t * (x2 - x1)
    yn = y1 + t * (y2 - y1)
    zn = z1 + t * (z2 - z1)
End If
LPDist = (ENormSq(x, y, z, xn, yn, zn)) ^ 0.5
End Function

Sub Main2()
Dim a%, b%, st$, curr%, an%, av#, sol%(), esum&, Lrow%, miss As Boolean
Sheets("Dat").Activate
ss() = Array("Travelling time: ", "Average neighbours per vertex: ", "Used holes: ", _
"Average visibility: ", "Stats ", "Holes", "Solution", "Input data missing.")
n = Cells(11, 9)
ForC
miss = False
If WorksheetFunction.CountBlank(Range("I11:I11")) > 0 Then miss = True
Lrow = n + 5
st = "c4:f" & Lrow
If WorksheetFunction.CountBlank(Range(st)) > 0 Then miss = True
If WorksheetFunction.CountBlank(Range("I8:I9")) > 0 Then miss = True
If miss Then
    MsgBox ss(8), vbCritical, "Worf Software"
    Exit Sub
End If
vc = Cells(8, 9)
vh = Cells(9, 9)
If vh <= vc Then
    vh = vc * 2
    Cells(9, 9) = vh
End If
ReDim vert(n + 2)
ReDim sol(n + 2)
Application.ScreenUpdating = False
For i = 1 To n + 2
    vert(i).visited = False
    vert(i).tim = 1E+200
    vert(i).previous = 0
    vert(i).nn = 0
    For j = 1 To n + 1
        vert(i).neig(j) = 0
    Next j
Next i
For i = 4 To 5 + n
    For j = 3 To 5
        vert(i - 3).c(j - 2) = Cells(i, j)
    Next j
    vert(i - 3).radius = Cells(i, 6)
Next i
For a = 1 To n + 2                          ' algorithm concept by Edsger Dijkstra
    Visibility a
Next a
curr = n + 1                                 ' origin
vert(curr).tim = 0
Do Until vert(n + 2).visited                 ' destination
    For i = 1 To vert(curr).nn
        an = vert(curr).neig(i)
        If Not vert(an).visited Then
            av = NTime(curr, an) + vert(curr).tim
            If av < vert(an).tim Then
                vert(an).tim = av
                vert(an).previous = curr
            End If
        End If
    Next i
    vert(curr).visited = True
    If curr = n + 2 Then Exit Do
    i = 0
    Do
        i = i + 1
    Loop Until Not vert(i).visited
    curr = i
    For i = 1 To n + 2
        If Not vert(i).visited Then
            If vert(i).tim < vert(curr).tim Then curr = i
        End If
    Next i
Loop
i = 1
Do
    sol(i) = curr
    curr = vert(curr).previous
    i = i + 1
Loop Until curr = 0
Sheets("Dat").Activate
Range("j3:k107").ClearContents
For j = 1 To i - 1
    Cells(j + 3, 10).Value = Cells(sol(j) + 3, 3)
    Cells(j + 3, 11).Value = Cells(sol(j) + 3, 4)
Next j
Cells(3, 10).Value = i - 1
PlotSol
Stat True
Application.ScreenUpdating = True
End Sub

Function NTime(first%, sec%) As Double      ' travelling time between nodes
Dim ndist#, lv#
ndist = LPDist(vert(first).c(1), vert(first).c(2), vert(first).c(3), vert(first).c(1), _
vert(first).c(2), vert(first).c(3), vert(sec).c(1), vert(sec).c(2), vert(sec).c(3))
lv = ndist - vert(first).radius - vert(sec).radius
If lv > 0 Then
    NTime = ((vert(first).radius + vert(sec).radius) / vh) + (lv / vc)
Else
    NTime = ndist / vh
End If
End Function

Sub Visibility(k%)
Dim aux%(), c%, nv As Boolean, d#, dc#, dd#
ReDim aux(n + 1)
c = 0                       ' neighbours of k
For i = 1 To n + 2           ' can k see i ?
    nv = True
    If i <> k Then
        For j = 1 To n + 2       ' the other holes
            If j <> i And j <> k Then
                d = LPDist(vert(k).c(1), vert(k).c(2), vert(k).c(3), vert(i).c(1), _
                vert(i).c(2), vert(i).c(3), vert(j).c(1), vert(j).c(2), vert(j).c(3))
                dc = LPDist(vert(i).c(1), vert(i).c(2), vert(i).c(3), vert(i).c(1), _
                vert(i).c(2), vert(i).c(3), vert(j).c(1), vert(j).c(2), vert(j).c(3)) _
                - vert(i).radius - vert(j).radius
                dd = LPDist(vert(k).c(1), vert(k).c(2), vert(k).c(3), vert(k).c(1), _
                vert(k).c(2), vert(k).c(3), vert(j).c(1), vert(j).c(2), vert(j).c(3)) _
                - vert(k).radius - vert(j).radius
                If d < vert(j).radius And dc > 0 And dd > 0 Then nv = False
            End If
        Next j
        If nv Then
            c = c + 1
            aux(c) = i
        End If
    End If
Next i
vert(k).nn = c
For i = 1 To c
    vert(k).neig(i) = aux(i)
Next
End Sub

Sub Generator()             ' input data
    Application.ScreenUpdating = False
    Sheets("Dat").Activate
    n = Cells(11, 9).Value
    Range("c4:f109").ClearContents
    For i = 4 To 5 + n
        For j = 3 To 5
            Randomize
            Cells(i, j).Value = -100 + 200 * Rnd
        Next j
        Cells(i, 6).Value = 2 + 30 * Rnd
    Next i
    Cells(n + 4, 6) = 0
    Cells(n + 5, 6) = 0
    ForC
    Application.ScreenUpdating = True
End Sub

Sub PlotSol()
    Dim Lrow%, li%, st$, cp%, pts As Points, Ltype&, SC2 As Series, SC3 As Series, sax As Axis
    Sheets("Solution").Activate
    ActiveSheet.ChartObjects(1).Activate
    ActiveChart.SeriesCollection(3).Delete
    ActiveChart.SeriesCollection(2).Delete
    Lrow = n + 3
    ActiveChart.SeriesCollection.NewSeries
    Set SC2 = ActiveChart.SeriesCollection(2)
    SC2.Name = ss(6)
    SC2.ChartType = xlXYScatter
    SC2.MarkerStyle = xlMarkerStyleCircle
    st = "='Dat'!$c$4:$c$" & Lrow
    SC2.XValues = st
    st = "='Dat'!$d$4:$d$" & Lrow
    SC2.Values = st
    For i = 1 To n
        SC2.Points(i).MarkerSize = DefMarker(vert(i).radius)
    Next i
    Ltype = SC2.ChartType
    SC2.ChartType = xlColumnClustered   ' otherwise transparency does not work
    For li = 1 To 2
        With SC2.Format.Fill
            .Solid
            .Visible = msoTrue
            .Transparency = 0.5
        End With
        SC2.ChartType = Ltype
        SC2.Format.Line.Weight = 3
        SC2.Format.Line.Visible = msoFalse
    Next
    For i = 1 To n
        SC2.Points(i).MarkerForegroundColor = RGB(0, EColor(vert(i).c(3)), 10)
    Next
    With ActiveChart
        .SeriesCollection.NewSeries
        .SeriesCollection(3).Name = ss(7)
    End With
    Set SC3 = ActiveChart.SeriesCollection(3)
    Lrow = 3 + Worksheets("Dat").Cells(3, 10).Value
    st = "='Dat'!$j$4:$j$" & Lrow
    SC3.XValues = st
    st = "='Dat'!$k$4:$k$" & Lrow
    With SC3
        .Values = st                        ' y values
        .ChartType = xlXYScatterLines
    End With
    Set pts = ActiveChart.SeriesCollection(3).Points
    pts(pts.Count).ApplyDataLabels
    pts(pts.Count).DataLabel.Text = "Amelia"
    pts(1).ApplyDataLabels
    pts(1).DataLabel.Text = "Otto"
    For i = 1 To pts.Count
        pts(i).MarkerSize = 6
    Next
    pts(1).MarkerBackgroundColor = RGB(0, EColor(vert(n + 2).c(3)), 0)
    pts(pts.Count).MarkerBackgroundColor = RGB(0, EColor(vert(n + 1).c(3)), 0)
    SC3.Border.Color = RGB(190, 20, 2)
    With ActiveChart.Legend
        .LegendEntries(2).Font.Color = 4
        .LegendEntries(3).Font.Color = 7
    End With
    Do
        For Each sax In ActiveChart.Axes
            If sax.AxisGroup = xlSecondary Then sax.Delete
        Next
    Loop Until ActiveChart.Axes.Count < 3
    CCopy
End Sub

Function EColor(tc#) As Integer     ' shade is based on
        Select Case tc              ' z coordinates
            Case -100 To -50
                EColor = 100
            Case -50 To 0
                EColor = 150
            Case 0 To 50
                EColor = 200
            Case 50 To 100
                EColor = 255
        End Select
End Function

Function DefMarker%(vr#)         ' marker size
    DefMarker = Round(2 + vr * 2.188, 0)
    If DefMarker > 72 Then DefMarker = 72
    If DefMarker < 2 Then DefMarker = 2
End Function

Sub Stat(op As Boolean)
Dim esum&, st$, nh%, ann#, sv!(4)
If op Then                  ' calculate and store values
    esum = 0
    For i = 1 To n + 2
        esum = esum + vert(i).nn
    Next
    sv(1) = vert(n + 2).tim
    sv(2) = esum / (n + 2)
    sv(3) = Sheets("Dat").Cells(3, 10).Value - 2
    sv(4) = (sv(2) * 100) / (n + 1)
    For i = 1 To 4
        Sheets("Dat").Cells(i, 40).FormulaR1C1 = sv(i)
    Next
Else                        ' retrieve last values
    For i = 1 To 4
        sv(i) = Sheets("Dat").Cells(i, 40)
    Next
End If
st = ss(1) & Format(sv(1), "0.0") & " s"
st = st & vbCrLf & ss(2) & Format(sv(2), "0.0")
st = st & vbCrLf & ss(3) & sv(3) & vbCrLf
st = st & ss(4) & Format(sv(4), "0.0") & "%"
MsgBox st, vbInformation, ss(5)
Sheets("LastGraph").Activate
[d4].Activate
End Sub

Sub Formatter(cr As Range, tcv%, tas!, wv%, pv%, cov As Boolean)
Dim ca(), i%
ca = Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight)
For i = 1 To 4
    With cr.Borders(ca(i))
        .LineStyle = xlContinuous
        .ThemeColor = tcv
        .TintAndShade = tas
        .Weight = wv
    End With
Next
With cr.Interior
    .Pattern = pv
    If cov Then .Color = 13434879
End With
If cov Then Cells(50, 30).FormulaR1C1 = cr.Address
End Sub

Sub ForC()
Dim frow%, lastc$, es$, st$
frow = n + 5
lastc = "c" & frow
lastc = lastc & ":" & "f" & frow
If Range(lastc).Borders(xlEdgeBottom).Weight <> xlMedium Then
    es = Cells(50, 30).Value
    Formatter Range(es), 1, -0.15, xlThin, xlNone, False
    st = "c4:f" & frow
    Formatter Range(st), 10, -0.5, xlMedium, xlSolid, True
    frow = frow + 1
    lastc = "c" & frow & ":" & "f105"
    Range(lastc).ClearContents
End If
End Sub

Sub CCopy()
Dim p As Object, t#, L#, w#, h#
For Each p In Sheets("LastGraph").Pictures
    p.Delete
Next
ActiveChart.CopyPicture
Sheets("LastGraph").Paste
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set p = Sheets("LastGraph").Pictures(1)
With Range("b2:y35")
        t = .Top
        L = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
End With
p.Top = t
p.Left = L
p.Width = w
p.Height = h
Set p = Nothing
End Sub