## Finding the shortest path – A * pathfinding

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:

- The distance to the END cell. (The distance to the END cell is calculated with the Manhattan distance method.
- 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.

Here is a slightly more advanced "map".

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

### 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

Create links to all sheets in a workbook

The macro demonstrated below creates hyperlinks to all worksheets in the current worksheet. You will then be able to quickly […]

Combine cell ranges eliminating blanks

This is an answer to Shawna´s question. The following user defined function merges up to 255 cell ranges and removes […]

Did you know that you can select all comments in the current sheet? Press F5, click "Special..." button, select "Comments" […]

The user defined function demonstrated below, resizes a range you specify to columns or rows you also specify. The first […]

How to use the FOR NEXT statement

The picture above demonstrates a FOR NEXT statement that goes through each cell value in cell range B3:B8 and adds it to […]

Optimize pick path in a warehouse

As you probably already are aware of I have shown you earlier a vba macro I made that finds the […]

I found a really interesting workbook that calculates the shortest distance from a start cell to an end cell. It […]

A quicker A * pathfinding algorithm

3 weeks ago I showed you a A* pathfinding algorithm. It was extremely slow and sluggish and I have now made it […]

### 5 Responses to “Finding the shortest path – A * pathfinding”

### Leave a Reply

### How to comment

**How to add a formula to your comment**

<code>Insert your formula here.</code>

**Convert less than and larger than signs**

Use html character entities instead of less than and larger than signs.

< becomes < and > becomes >

**How to add VBA code to your comment**

[vb 1="vbnet" language=","]

Put your VBA code here.

[/vb]

**How to add a picture to your comment:**

Upload picture to postimage.org or imgur

Use the img tag, like this: <img src="Insert pic link here">

**Contact Oscar**

You can contact me through this contact form

[…] I guess this is a task for vba but that will be another post. [UPDATE] The follow up post is here: Finding the shortest path – A * pathfinding […]

impressive!

Torstein,

Thank you but the idea is not mine. The A * algorithm is used in many computer games.

It is a very interesting technique and I believe I can make my macro run a lot quicker with some minor changes.

[UPDATE]

A quicker A * pathfinding algorithm

[…] Finding the shortest path – A * pathfinding […]

Nice explanation :) Here are some other visualizations with extra info, helping to better understand A* (along with forkeable examples): https://thewalnut.io/visualizer/visualize/7/6/