# Dijkstra's algorithm with VBA

Excel Version
1. 2013
This article shows how to use Dijkstra's algorithm to solve the tridimensional problem stated below.

Dijkstra's algorithm - Wikipedia

• Actually, this is a generic solution where the speed inside the holes is a variable. The original problem is a particular case where this speed goes to infinity.
• Amelia, Otto and the holes are vertices; imaginary lines connecting vertices are edges, and two vertices connected by an edge are neighbours.
• Edges pass through hole centres, hence there is no direct path between all hole pairs, since you can only travel using edges. In other words, a given vertex will have partial visibility.
The link to the workbook is below. At the data sheet, you can:
• Choose the number of holes, between 1 and 100.
• Generate an input table or insert it manually. This table will be (n+2) rows long; first n rows are vertex data, and the last two are for Amelia and Otto.
• Solve the problem by pressing a button.
• Define Amelia’s speed into solid cheese and inside the holes. Air travelling should be faster.
A 2D representation of the solution is produced; the higher in the cheese a hole is, the lighter its border colour will be.
• To visualize again the last statistics, press the button at the solution sheet.
• A picture of the most recent solution is at the last graph sheet.

Cheese_v21.xlsm

VBA Code:
``````Option Explicit
Option Base 1

Type Vertex
c(3) As Double          ' coordinates
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))
If lv > 0 Then
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)) _
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)) _
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
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
.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``````
Author
Worf
Views
9,584
First release
Last update
Rating
0 ratings

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back