undifusion
New Member
- Joined
- Mar 14, 2009
- Messages
- 6
Well heres the problem.
Anyone fancy having a bash at it?

Anyone fancy having a bash at it?

Option Explicit
Option Base 0
Public playingField As Range
Public vPlayField() As Variant
Public DummyCell As Range
Public Const GoalColorIndex As Long = 34
Public Const WallColorIndex As Long = 44
Sub Demo()
SolveMaze ActiveSheet
End Sub
Function SolveMaze(onSheet As Worksheet, Optional EraseFootprints As Boolean, Optional EraseHistory As Boolean) As String
Dim StartCell As Range, startCellChr As Variant
Dim GoalCell As Range
Dim furthestCells As Range, nextStep As Range
Dim stepCount As Long
Dim ReversePath() As Range
Dim i As Long
Dim oneCell As Range, tempRange As Object
Dim Begin As Single
Rem get starting cell
Set StartCell = GetStartCell(onSheet)
If StartCell Is Nothing Then
SolveMaze = "No starting cell": Rem error msg
GoTo BypassAll
End If
Rem control erasure
If Not (EraseFootprints Or EraseHistory) Then
Select Case MsgBox(prompt:="Ignore " & vbTab & "- erase nothing" & vbCr _
& " Retry " & vbTab & "- erase only Footprints" & vbCr _
& " Abort " & vbTab & "- erase History and Footprints", _
Buttons:=vbAbortRetryIgnore + vbDefaultButton3)
Case Is = vbAbort
EraseFootprints = True
EraseHistory = True
Case Is = vbIgnore
EraseFootprints = False
EraseHistory = False
Case Is = vbRetry
EraseFootprints = True
EraseHistory = False
End Select
End If
Begin = Timer
startCellChr = IIf(UCase(CStr(StartCell.Value)) = "S", Chr(34) & "S" & Chr(34), 0)
If StartCell.Interior.ColorIndex = GoalColorIndex Then
SolveMaze = "Notice that " & StartCell.Address(False, False) & " is a goal cell.": Rem error msg
GoTo WriteResultInComment
End If
Rem initialize map of maze
Set playingField = playingFieldRange(StartCell)
With playingField
Rem find a dummyCell outside of playingfield
Set DummyCell = .Cells(.Rows.Count + 1, 1)
Rem initialize step count array
ReDim vPlayField(1 To .Rows.Count, 1 To .Columns.Count)
End With
Rem initialize stepping loop
Set furthestCells = StartCell
stepCount = 0
LetVCellValue StartCell, stepCount
Do
Rem get cells after next step
stepCount = stepCount + 1
Set nextStep = DummyCell
For Each oneCell In furthestCells
Set tempRange = NeighborsOf(oneCell, GoalCell)
If Not tempRange Is Nothing Then
Set nextStep = Application.Union(nextStep, tempRange)
End If
Next oneCell
Set nextStep = Application.Intersect(nextStep, playingField)
If nextStep Is Nothing Then
Rem all paths double back on themselves
Rem error message
SolveMaze = "No path from " & StartCell.Address(False, False) & vbCr
startCellChr = Chr(34) & "X" & Chr(34)
ReDim ReversePath(0 To 0): Set ReversePath(0) = StartCell
GoTo AddTimeToResult
Else
For Each oneCell In nextStep
LetVCellValue oneCell, stepCount
Next oneCell
End If
Set furthestCells = nextStep
Loop While GoalCell Is Nothing
Rem a path has been found
Rem pick one of the found paths
ReDim ReversePath(1 To stepCount)
Set ReversePath(stepCount) = GoalCell
For i = stepCount - 1 To 1 Step -1
Set ReversePath(i) = NextBackwardStep(ReversePath(i + 1))
Next i
Rem display the results
SolveMaze = "Path from " & StartCell.Address(False, False) & " to " & GoalCell.Address(False, False) & vbCr
SolveMaze = SolveMaze & "takes " & stepCount & " steps" & vbCr & "and "
AddTimeToResult:
SolveMaze = SolveMaze & Format((Timer - Begin), "#.00") & " seconds."
Rem clear playingfield
With playingField
If EraseFootprints Then .Parent.Cells.ClearContents
If EraseHistory Then
With .Parent.Cells
.Validation.Delete
.ClearComments
End With
End If
On Error Resume Next
.SpecialCells(xlCellTypeConstants).Font.ColorIndex = 50
.SpecialCells(xlCellTypeConstants).Value = Chr(165)
.SpecialCells(xlCellTypeFormulas, xlNumbers).Formula = "=" & Chr(34) & Chr(165) & Chr(34)
On Error GoTo 0
End With
Rem display solution path
For i = LBound(ReversePath) To UBound(ReversePath)
'Call Delay
With ReversePath(i)
.Value = i
.Font.ColorIndex = xlGuess
'.Interior.ColorIndex = 3
End With
Next i
With StartCell
.Formula = "=" & startCellChr
With .Font
.Bold = True
.ColorIndex = 3
End With
End With
Rem printStatistics
WriteResultInComment:
With StartCell
On Error Resume Next
.AddComment
.Validation.Add xlValidateInputOnly
On Error GoTo 0
.Validation.InputMessage = SolveMaze
With .Comment
.Shape.TextFrame.Characters.Font.Size = 12
.Text Text:=SolveMaze
.Visible = False
End With
Application.Goto .Cells(1, 1)
.Validation.Delete
End With
BypassAll:
End Function
Function NeighborsOf(ByVal myCell As Range, Optional ByRef GoalCell As Range) As Range
Dim oneNeighbor As Range
If myCell Is Nothing Then
Set NeighborsOf = Nothing
Else
Set NeighborsOf = DummyCell
With myCell.Cells(1, 1)
On Error Resume Next
If IsGoodNeighbor(.Offset(-1, 0), GoalCell) Then Set NeighborsOf = Application.Union(NeighborsOf, .Offset(-1, 0))
If IsGoodNeighbor(.Offset(0, 1), GoalCell) Then Set NeighborsOf = Application.Union(NeighborsOf, .Offset(0, 1))
If IsGoodNeighbor(.Offset(0, -1), GoalCell) Then Set NeighborsOf = Application.Union(NeighborsOf, .Offset(0, -1))
If IsGoodNeighbor(.Offset(1, 0), GoalCell) Then Set NeighborsOf = Application.Union(NeighborsOf, .Offset(1, 0))
On Error GoTo 0
End With
Set NeighborsOf = Application.Intersect(NeighborsOf, playingField)
End If
End Function
Function IsGoodNeighbor(testCell As Range, Optional ByRef GoalCell As Range) As Boolean
Rem test cell is not already in path AND not a wall
IsGoodNeighbor = IsEmpty(GetVCellValue(testCell)) And (testCell.Interior.ColorIndex <> WallColorIndex)
Rem test cell is a goal cell
If IsGoodNeighbor And testCell.Interior.ColorIndex = GoalColorIndex Then Set GoalCell = testCell
End Function
Function NextBackwardStep(inputCell As Range) As Range
Dim oneCell As Range
With inputCell
On Error Resume Next
If (GetVCellValue(.Offset(1, 0)) = (GetVCellValue(inputCell) - 1)) And (.Offset(1, 0).Interior.ColorIndex <> WallColorIndex) Then Set NextBackwardStep = .Offset(1, 0)
If (GetVCellValue(.Offset(0, 1)) = (GetVCellValue(inputCell) - 1)) And (.Offset(0, 1).Interior.ColorIndex <> WallColorIndex) Then Set NextBackwardStep = .Offset(0, 1)
If (GetVCellValue(.Offset(-1, 0)) = (GetVCellValue(inputCell) - 1)) And (.Offset(-1, 0).Interior.ColorIndex <> WallColorIndex) Then Set NextBackwardStep = .Offset(-1, 0)
If (GetVCellValue(.Offset(0, -1)) = (GetVCellValue(inputCell) - 1)) And (.Offset(0, -1).Interior.ColorIndex <> WallColorIndex) Then Set NextBackwardStep = .Offset(0, -1)
On Error GoTo 0
End With
End Function
Function GetStartCell(MazeSheet As Worksheet) As Range
Rem look for "S"
With MazeSheet
On Error Resume Next
Set GetStartCell = .Cells.Find(What:="S", After:=.Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
On Error GoTo 0
End With
Rem if not there, ask user
If GetStartCell Is Nothing Then
MazeSheet.Activate
On Error Resume Next
Set GetStartCell = Application.InputBox("Click on the Starting cell.", Default:=ActiveCell.Address, Type:=8).Cells(1, 1)
On Error GoTo 0
End If
Rem validate: single cell ; cell is not a wall
If Not GetStartCell Is Nothing Then
Set GetStartCell = GetStartCell.Cells(1, 1)
If (GetStartCell.Interior.ColorIndex = WallColorIndex) Then Set GetStartCell = Nothing
End If
End Function
Function playingFieldRange(startingCell As Range) As Range
With startingCell.Parent
Set playingFieldRange = .Cells(1, 1).Resize(.Rows.Count / 2 - 1, .Columns.Count)
Exit Function
Rem this code is faster but not as stable
Set playingFieldRange = startingCell.Cells(1, 1).Offset(1, 1)
Set playingFieldRange = Range(playingFieldRange, .UsedRange.Offset(1, 1))
Set playingFieldRange = Range(playingFieldRange, .Range("A1"))
End With
End Function
Function GetVCellValue(aCell As Range) As Variant
If aCell Is Nothing Then
GetVCellValue = CVErr(xlErrRef)
Else
With aCell
GetVCellValue = vPlayField(.Row, .Column)
End With
End If
End Function
Sub LetVCellValue(aCell As Range, Value As Variant)
With aCell
vPlayField(.Row, .Column) = Value
End With
End Sub
Sub ClearHistory()
With ActiveSheet.Cells
.ClearComments
.ClearContents
.Validation.Delete
End With
End Sub
Sub ClearFootprints()
ActiveSheet.Cells.ClearContents
MsgBox "cleared"
End Sub
Sub colorCorrection()
Dim orangeColor As Long, pBlueColor As Long
Rem 41-LtBlue, 33-skyBlue, 37-paleBlue
Rem 46-orange
With ThisWorkbook
.ResetColors
orangeColor = .Colors(WallColorIndex)
.Colors(WallColorIndex) = .Colors(46)
.Colors(46) = orangeColor
pBlueColor = .Colors(GoalColorIndex)
.Colors(GoalColorIndex) = .Colors(37)
.Colors(37) = pBlueColor
End With
End Sub