Sub Moves()
Dim Start, Dice, Colouring As String
Start = "S43"
Dice = "12"
Range("B1:AK95").Interior.Color = xlNone
Range("S44:X50").Interior.Color = 12566463
Range("K45:M47").Interior.Color = 12566463
Range(Start).Activate
'Initial Grid
For x = 0 To Dice
For y = 0 To Dice
If Range(Start).Offset(x, y).Interior.Color <> 12566463 And x + y < Dice + 1 Then Range(Start).Offset(x, y).Interior.Color = 255
If Range(Start).Offset(-x, y).Interior.Color <> 12566463 And x + y < Dice + 1 Then Range(Start).Offset(-x, y).Interior.Color = 255
If Range(Start).Offset(x, -y).Interior.Color <> 12566463 And x + y < Dice + 1 Then Range(Start).Offset(x, -y).Interior.Color = 255
If Range(Start).Offset(-x, -y).Interior.Color <> 12566463 And x + y < Dice + 1 Then Range(Start).Offset(-x, -y).Interior.Color = 255
Next y
Next x
Try1:
For t = 1 To 20 '20 Atempts at finding path
Range(Start).Activate
For c = 1 To Dice
For n = 1 To 4
On Error Resume Next
If ActiveCell.Offset(-n, 0).Interior.Color = 255 Then ActiveCell.Offset(-1, 0).Activate: GoTo Colour
If ActiveCell.Offset(0, n).Interior.Color = 255 Then ActiveCell.Offset(0, 1).Activate: GoTo Colour
If ActiveCell.Offset(n, 0).Interior.Color = 255 Then ActiveCell.Offset(1, 0).Activate: GoTo Colour
If ActiveCell.Offset(0, -n).Interior.Color = 255 Then ActiveCell.Offset(0, -1).Activate: GoTo Colour
Next n
Directions: 'If no red near, choose random direction
d = Int((4 - 1 + 1) * Rnd + 1)
If d = 1 And ActiveCell.Offset(-1, 0).Interior.Color <> 12566463 Then ActiveCell.Offset(-1, 0).Activate: GoTo Colour
If d = 2 And ActiveCell.Offset(0, 1).Interior.Color <> 12566463 Then ActiveCell.Offset(0, 1).Activate: GoTo Colour
If d = 3 And ActiveCell.Offset(1, 0).Interior.Color <> 12566463 Then ActiveCell.Offset(1, 0).Activate: GoTo Colour
If d = 4 And ActiveCell.Offset(0, -1).Interior.Color <> 12566463 Then ActiveCell.Offset(0, -1).Activate: GoTo Colour
GoTo Directions
Colour:
If ActiveCell.Interior.Color = 12566463 Then GoTo Try1
ActiveCell.Interior.Color = 0
Next c
Next t
Try2:
For t = 1 To 20
Range(Start).Activate
For c = 1 To Dice
For n = 1 To 7
On Error Resume Next
If ActiveCell.Offset(0, -n).Interior.Color = 255 Then ActiveCell.Offset(0, -1).Activate: GoTo Colour2
If ActiveCell.Offset(n, 0).Interior.Color = 255 Then ActiveCell.Offset(1, 0).Activate: GoTo Colour2
If ActiveCell.Offset(0, n).Interior.Color = 255 Then ActiveCell.Offset(0, 1).Activate: GoTo Colour2
If ActiveCell.Offset(-n, 0).Interior.Color = 255 Then ActiveCell.Offset(-1, 0).Activate: GoTo Colour2
Next n
Direction:
d = Int((4 - 1 + 1) * Rnd + 1)
If d = 1 And ActiveCell.Offset(-1, 0).Interior.Color <> 12566463 Then ActiveCell.Offset(-1, 0).Activate: GoTo Colour2
If d = 2 And ActiveCell.Offset(0, 1).Interior.Color <> 12566463 Then ActiveCell.Offset(0, 1).Activate: GoTo Colour2
If d = 3 And ActiveCell.Offset(1, 0).Interior.Color <> 12566463 Then ActiveCell.Offset(1, 0).Activate: GoTo Colour2
If d = 4 And ActiveCell.Offset(0, -1).Interior.Color <> 12566463 Then ActiveCell.Offset(0, -1).Activate: GoTo Colour2
GoTo Direction
Colour2:
If ActiveCell.Interior.Color = 12566463 Then GoTo Try2
ActiveCell.Interior.Color = 0
Next c
Next t
'Grid......
Range(Start).Offset(-Dice, -Dice).Activate
For x = 0 To (Dice * 2)
For y = 0 To (Dice * 2)
If ActiveCell.Offset(x, y).Interior.Color = 0 And (x + y) Mod 2 = 0 Then ActiveCell.Offset(x, y).Interior.Color = 15773696
Next y
Next x
If Dice Mod 2 = 0 Then Colouring = 0 Else Colouring = 15773696
For x = 0 To (Dice * 2)
For y = 0 To (Dice * 2)
If ActiveCell.Offset(x, y).Interior.Color = Colouring Then ActiveCell.Offset(x, y).Interior.Color = xlNone
Next y
Next x
For x = 0 To (Dice * 2)
For y = 0 To (Dice * 2)
If ActiveCell.Offset(x, y).Interior.Color = 15773696 Then ActiveCell.Offset(x, y).Interior.Color = 192
If ActiveCell.Offset(x, y).Interior.Color = 0 Then ActiveCell.Offset(x, y).Interior.Color = 192
If ActiveCell.Offset(x, y).Interior.Color = 255 Then ActiveCell.Offset(x, y).Interior.Color = xlNone
Next y
Next x
End Sub