Two months ago I posted some interesting stuff I found: Shortest path. Let me explain, someone created a workbook that calculated the shortest path between a start cell and an end cell in a maze, and it did that using only formulas. Pretty amazing. The formulas were made from Dijkstra's Algorithm. I tried to create a larger maze but the workbook grew too large.

I then found the A * pathfinding algorithm and it is a lot easier for the computer to calculate. There is a great explanation of the A * pathfinding algorithm here: Introduction to A* Pathfinding.

Basically, there is an open list, a closed list and a final path. The open list contains cells that are being considered to find the final path. The closed list contains cell that we don´t need to consider again.

They all contain coordinates or cells based on criteria. The criteria are:

  1. The distance to the END cell. (The distance to the END cell is calculated with the Manhattan distance method.
  2. The distance traveled from the start cell.

If the END cell is added to the open list, the closed list is finished calculating. Now it is time to find the final path. The final path is also found using the Manhattan distance method but it can only travel on cells in the closed list.

Here is an animated picture, it shows you how the macro works, simplified.

  • Blue cell is the start cell
  • Red cell is the end cell
  • Gray cells are cells in the closed list.
  • Green cells are the final path.
  • Black cells are walls.

Find shortest path1

 

Here is a slightly more advanced "map".

Find shortest path3

This is a maze. I have removed the closed list cells to make the macro quicker.

Find shortest path4

VBA Code

Sub FindShortestPath1()
Application.ScreenUpdating = False
Dim G() As Variant
Dim H() As Variant
Dim N() As Variant
Dim OL() As Variant
Dim CL() As Variant
Dim S() As Variant
Dim E() As Variant
Dim W() As Variant
Dim Gv() As Variant
Dim i As Single
ReDim S(0 To 1)
ReDim E(0 To 1)
ReDim W(0 To 3, 0 To 1)
ReDim OL(0 To 1, 0)
ReDim CL(0 To 1, 0)
ReDim Gv(0 To 3)
Rng = Range("Area").Value
a = UBound(Rng, 1) - 1
b = UBound(Rng, 2) - 1
ReDim G(0 To a, 0 To b)
ReDim H(0 To a, 0 To b)
ReDim N(0 To a, 0 To b)
For R = 1 To UBound(Rng, 1)
    For C = 1 To UBound(Rng, 2)
        If Rng(R, C) = "S" Then
            S(0) = R - 1
            S(1) = C - 1
        End If
        If Rng(R, C) = "E" Then
            E(0) = R - 1
            E(1) = C - 1
        End If
        If S(0) <> "" And E(0) <> "" Then Exit For
    Next C
Next R
CL(0, 0) = S(0) 'row
CL(1, 0) = S(1) 'column
W(0, 0) = -1
W(1, 0) = 1
W(2, 0) = 0
W(3, 0) = 0
W(0, 1) = 0
W(1, 1) = 0
W(2, 1) = -1
W(3, 1) = 1
Echk = False
Do Until Echk = True
    For i = 0 To UBound(CL, 2)
        For j = 0 To 3
            chk = False
            tr = CL(0, i) + W(j, 0)
            tc = CL(1, i) + W(j, 1)
            If tr < 0 Or tc < 0 Or tr > UBound(Rng, 1) Or tc > UBound(Rng, 2) Then
                chk = True
            Else
                For k = UBound(CL, 2) To 0 Step -1
                        If tr = CL(0, k) And tc = CL(1, k) Then
                            chk = True
                            Exit For
                        End If
                Next k
                If Rng(tr + 1, tc + 1) = 1 Then chk = True
                For k = UBound(OL, 2) To 0 Step -1
                    If tr = OL(0, k) And tc = OL(1, k) Then
                        chk = True
                        If G(CL(0, i), CL(1, i)) + 1 < G(tr, tc) Then
                            G(tr, tc) = G(CL(0, i), CL(1, i)) + 1
                            H(tr, tc) = Abs(tr - E(0)) + Abs(tc - E(1))
                            N(tr, tc) = G(tr, tc) + H(tr, tc)
                        End If
                        Exit For
                    End If
                Next k
                If chk = False Then
                    OL(0, UBound(OL, 2)) = tr
                    OL(1, UBound(OL, 2)) = tc
                    ReDim Preserve OL(UBound(OL, 1), UBound(OL, 2) + 1)
                    G(tr, tc) = G(CL(0, i), CL(1, i)) + 1
                    H(tr, tc) = Abs(tr - E(0)) + Abs(tc - E(1))
                    N(tr, tc) = G(tr, tc) + H(tr, tc)
                    If Rng(tr + 1, tc + 1) = "E" Then Echk = True
                End If
            End If
        Next j
    Next i
    If Echk <> True Then
        For i = LBound(OL, 2) To UBound(OL, 2)
            If OL(0, i) <> "" Then
                Nchk = N(OL(0, i), OL(1, i))
                Exit For
            End If
        Next i
        For i = LBound(OL, 2) To UBound(OL, 2)
            If OL(1, i) <> "" Then
                If N(OL(0, i), OL(1, i)) < Nchk And N(OL(0, i), OL(1, i)) <> "" Then
                    Nchk = N(OL(0, i), OL(1, i))
                End If
            End If
        Next i
        For i = LBound(OL, 2) To UBound(OL, 2)
            If OL(0, i) <> "" Then
                If N(OL(0, i), OL(1, i)) = Nchk Then
                    ReDim Preserve CL(UBound(CL, 1), UBound(CL, 2) + 1)
                    CL(0, UBound(CL, 2)) = OL(0, i)
                    OL(0, i) = ""
                    CL(1, UBound(CL, 2)) = OL(1, i)
                    OL(1, i) = ""
                End If
            End If
        Next i
    End If
Loop
tr = E(0)
tc = E(1)
Schk = False
Do Until Schk = True
    For i = UBound(CL, 2) To 0 Step -1
        If CL(0, i) = (tr + 1) And CL(1, i) = tc _
            And (Rng(tr + 2, tc + 1) <> "W" _
            And Rng(tr + 2, tc + 1) <> "1") _
            Then Gv(0) = G(tr + 1, tc)
        If CL(0, i) = tr And CL(1, i) = (tc + 1) _
            And (Rng(tr + 1, tc + 2) <> "W" _
            And Rng(tr + 1, tc + 2) <> "1") _
            Then Gv(1) = G(tr, tc + 1)
        If CL(0, i) = (tr - 1) And CL(1, i) = tc _
            And (Rng(tr, tc + 1) <> "W" _
            And Rng(tr, tc + 1) <> "1") _
            Then Gv(2) = G(tr - 1, tc)
        If CL(0, i) = tr And CL(1, i) = (tc - 1) _
            And (Rng(tr + 1, tc) <> "W" _
            And Rng(tr + 1, tc) <> "1") _
            Then Gv(3) = G(tr, tc - 1)
        For j = 0 To 3
            If Gv(j) <> "" Then Nf = Gv(j)
        Next j
        For j = 0 To 3
            If Gv(j) < Nf And Gv(j) <> "" Then Nf = Gv(j)
        Next j
    Next i
  Application.ScreenUpdating = True
    Select Case Nf
        Case Gv(0)
            tr = tr + 1
            Range("Area").Cells(tr + 1, tc + 1) = "W"
            Rng(tr + 1, tc + 1) = "W"
        Case Gv(1)
            tc = tc + 1
            Range("Area").Cells(tr + 1, tc + 1) = "W"
            Rng(tr + 1, tc + 1) = "W"
        Case Gv(2)
            tr = tr - 1
            Range("Area").Cells(tr + 1, tc + 1) = "W"
            Rng(tr + 1, tc + 1) = "W"
        Case Gv(3)
            tc = tc - 1
            Range("Area").Cells(tr + 1, tc + 1) = "W"
            Rng(tr + 1, tc + 1) = "W"
    End Select
    If Rng(tr + 2, tc + 1) = "S" _
        Or Rng(tr + 1, tc + 2) = "S" _
        Or Rng(tr, tc + 1) = "S" _
        Or Rng(tr + 1, tc) = "S" Then Schk = True
Loop
Application.ScreenUpdating = True
End Sub

Download excel *.xlsm file

Find shortest path.xlsm