Finding shortest path between two points

[PetrHoracek]

Hey, so I'm working on a simulation project and I've encountered an obstacle.

Here's a representation of the problem:

Výstřižek.PNG

I want to find a path from A to C (or C to A, doesn't really matter), that's as short as possible. The W's represent walls, that cannot be crossed. Also, the path can't be diagonal, only ortogonal.
I've been trying to come up with a solution, but no luck so far.

Is this even possible to do?

Thanks for any advice. Have a nice day.
Petr

[WideBoyDixon]

I wrote an exhaustive recursive function to find the shortest path:

Private bestPath As String
Public Sub FindShortestPath()

Dim startCell As Range
Dim endCell As Range
Dim startPath As String
Dim nextMove As Long

Set startCell = Cells.Find("A")
Set endCell = Cells.Find("C")
bestPath = Space$(1024)

Application.ScreenUpdating = False
TryMoves startPath, startCell, endCell
Application.ScreenUpdating = True

For nextMove = 1 To Len(bestPath) - 1
    Set startCell = MakeMove(startCell, CLng(Mid(bestPath, nextMove, 1)))
    startCell.Formula = "=MID($Z$1," & Mid(bestPath, nextMove, 1) + 1 & ",1)"
Next nextMove

End Sub
Private Sub TryMoves(currentPath As String, currentCell As Range, targetCell As Range)

Dim thisMove As Long
Dim newCell As Range

If Len(currentPath) >= Len(bestPath) Then Exit Sub

For thisMove = 0 To 3
    Set newCell = MakeMove(currentCell, thisMove)
    If newCell.Address = targetCell.Address Then
        ' Found a path
        If Len(currentPath) + 1 < Len(bestPath) Then bestPath = currentPath & CStr(thisMove)
    ElseIf newCell.Value = "" Then
        newCell.Value = "X"
        TryMoves currentPath & CStr(thisMove), newCell, targetCell
        newCell.Value = ""
    End If
Next thisMove

End Sub
Private Function MakeMove(currentCell As Range, direction As Long) As Range

Select Case direction
    Case 0
        Set MakeMove = currentCell.Offset(-1, 0)
    Case 1
        Set MakeMove = currentCell.Offset(0, 1)
    Case 2
        Set MakeMove = currentCell.Offset(1, 0)
    Case 3
        Set MakeMove = currentCell.Offset(0, -1)
End Select

End Function
Public Sub ClearPath()

Cells.SpecialCells(xlCellTypeFormulas).ClearContents

End Sub

See attached. If you want to see it in action, comment out the line which turns off screen updating.

WBD

[PetrHoracek]

Wow, thanks a lot. I will look into it. Much appreciated!

[sintek]

This is going to be an interesting one...Wanna see how this plays out...
Does the letter W always represent a brick in a wall...Is the markers always A and C or are other letters in the alphabet used...
How must the path be displayed...Interior cell color changes...step by step cell reference etc etc

[PetrHoracek]

Hey, yeah, the W is like a brick, impassable. Letters A and C are just an example, it could be any letter.

Regarding how the path is going to be displayed and the other things... I really don't know either. I am just assisting the main programmer who works on this project, as a summer job before school starts. He basically just told me he wants to find a shortest path between two cells and that's it. I'll probably tell you more when i see him again.

[sintek]

Just for the fun of it...Would fall apart if the maze was more elaborate though...

Option Explicit

Sub Find_Shortest_Path()
Dim start As Range, finish As Range, rng As Range
Dim rwDiff As Long, rw As Long, wCnt As Long, r As Long, c As Long
Dim found As Boolean, sign As String
Application.ScreenUpdating = False
Set start = Cells.Find("A"): Set finish = Cells.Find("C")
start.Select: rw = start.Row
Do Until found = True
    rwDiff = rw - finish.Row
    Set rng = Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(ActiveCell.Row, finish.Column))
    wCnt = Application.WorksheetFunction.CountIf(rng, "W")
    Select Case rwDiff
        Case Is < 0
            If wCnt = 0 Then sign = "" Else sign = "-"
        Case Is = 0
            If wCnt = 0 Then sign = "" Else sign = "-"
        Case Else
            sign = "-"
    End Select
    If wCnt = 0 Then If rwDiff > 0 Then c = 0: r = 1 Else: c = 1: r = 0 Else r = 1: c = 0
    If ActiveCell.Column = finish.Column Then c = 0:  If ActiveCell.Row < finish.Row Then r = 1
    If ActiveCell.Offset(sign & r, c) <> "W" Then
        If ActiveCell.Offset(sign & r, c).Address = finish.Address Then
            found = True
        Else
            ActiveCell.Offset(sign & r, c) = "X"
            ActiveCell.Offset(sign & r, c).Select
            rw = ActiveCell.Row
        End If
    End If
Loop
Application.ScreenUpdating = True
End Sub

Just for interest sake...I have attached a file I found on the net...
The left area [A:L] allows you to enter 1 into a cell to create an amazing elaborate maze...
The right area [O:Y] depicts the path...