• If you would like to post, please check out the MrExcel Message Board FAQ and click here to register.
    If you forgot your password, you can reset your password.
  • Excel articles and downloadable files provided in the articles have not been reviewed by MrExcel Publishing. Please apply the provided methods / codes and open the files at your own risk.
    If you have any questions regarding an article, please use the Article Discussion section.
Worf

Dijkstra's algorithm with VBA

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

cheese.JPG


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

cheesegraph.JPG



VBA Code:
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
Excel Version
2013
  • Like
Reactions: shg
Author
Worf
Views
1,125
First release
Last update
Rating
0.00 star(s) 0 ratings

More Excel articles from Worf

Some videos you may like

This Week's Hot Topics

Top