Tilexcel
Here is another interesting puzzle. The tiles have to be placed so that the 4 numbers of each tile touch the same numbers on all the tiles next to it. The right is the pool of tiles to place in the correct place in the puzzle on the left.
Below is one that's completed. Notice that the 6 of tile 1 touches the 6 of tile 2 and the 8 of tile 2 touches the 8 of tile 3. Also, tile 5 from the pool on the right was used as tile 1 in left puzzle and tile 2 on the right was placed as the second tile in the puzzle, which happens to be the same position.
A tile could also look like below and even the center number could be invisible by changing its color to white or, perhaps, a faint grey.
The puzzle is somewhat stretched out to make the number creation efficient. There are small rows and columns between the tiles to separate the tiles slightly. The picture below reveals what rows and columns I finished up with for this game.
This now gives enough information to do the graphics.
The first task is to create the numbers for the puzzle in the Module.
Sub SetupLeftTiles()
Dim intLoopA As Integer
Dim intLoopB As Integer
'Insert random numbers in left tiles
For intLoopA = 6 To 24 Step 6
For intLoopB = 5 To 29 Step 6
Randomize
Cells(intLoopA, intLoopB) = Int(Rnd * 10)
Cells(intLoopA, intLoopB - 4) = Cells(intLoopA, intLoopB)
Randomize
Cells(intLoopB, intLoopA) = Int(Rnd * 10)
Cells(intLoopB - 4, intLoopA) = Cells(intLoopB, intLoopA)
Next intLoopB
Next intLoopA
End Sub
The tiles are now transferred randomly to the right puzzle block. In column BB starting at row 34 are the positions of the tiles so that hints can be displayed as to where tiles belong. The numbers are also cycled through to check whether the puzzle is solved.
Sub TransferTilesRandomlyToRight()
Dim intRndRow As Integer
Dim intRndCol As Integer
Dim intLoopRow As Integer
Dim intLoopCol As Integer
Dim intLoop As Integer
Dim intCheck As Integer
Dim blnCheck As Boolean
'Clear position table including hint
Range(Cells(34, 53), Cells(50, 54)).ClearContents
'Clear the Hint number
Cells(48, 7) = ""
For intLoopRow = 0 To 3
For intLoopCol = 0 To 3
'Find an un-used tile number
Do
Randomize
intRndRow = Int(Rnd * 4)
intRndCol = Int(Rnd * 4)
blnCheck = True
'By looping through the table
For intCheck = 34 To 49
If Cells(intCheck, 54) = intRndRow * 4 + 1 + intRndCol Then
blnCheck = False
End If
Next intCheck
Loop Until blnCheck = True
'record position of tile
Cells(34 + intLoop, 54) = intRndRow * 4 + 1 + intRndCol
'Copy the numbers for each tile from left to right puzzle
Cells(5 + intRndRow * 6, 32 + intRndCol * 6) = Cells(5 + intLoopRow * 6, 6 + intLoopCol * 6)
Cells(6 + intRndRow * 6, 31 + intRndCol * 6) = Cells(6 + intLoopRow * 6, 5 + intLoopCol * 6)
Cells(6 + intRndRow * 6, 33 + intRndCol * 6) = Cells(6 + intLoopRow * 6, 7 + intLoopCol * 6)
Cells(7 + intRndRow * 6, 32 + intRndCol * 6) = Cells(7 + intLoopRow * 6, 6 + intLoopCol * 6)
intLoop = intLoop + 1
Next intLoopCol
Next intLoopRow
End Sub
This results into the following. The first figure in the BB column indicates that tile 7 is the tile to be placed in position 1 in the top left corner.
The first task is to create the numbers for the puzzle in the Module.
Sub SetupLeftTiles()
Dim intLoopA As Integer
Dim intLoopB As Integer
'Insert random numbers in left tiles
For intLoopA = 6 To 24 Step 6
For intLoopB = 5 To 29 Step 6
Randomize
Cells(intLoopA, intLoopB) = Int(Rnd * 10)
Cells(intLoopA, intLoopB - 4) = Cells(intLoopA, intLoopB)
Randomize
Cells(intLoopB, intLoopA) = Int(Rnd * 10)
Cells(intLoopB - 4, intLoopA) = Cells(intLoopB, intLoopA)
Next intLoopB
Next intLoopA
End Sub
The tiles are now transferred randomly to the right puzzle block. In column BB starting at row 34 are the positions of the tiles so that hints can be displayed as to where tiles belong. The numbers are also cycled through to check whether the puzzle is solved.
Sub TransferTilesRandomlyToRight()
Dim intRndRow As Integer
Dim intRndCol As Integer
Dim intLoopRow As Integer
Dim intLoopCol As Integer
Dim intLoop As Integer
Dim intCheck As Integer
Dim blnCheck As Boolean
'Clear position table including hint
Range(Cells(34, 53), Cells(50, 54)).ClearContents
'Clear the Hint number
Cells(48, 7) = ""
For intLoopRow = 0 To 3
For intLoopCol = 0 To 3
'Find an un-used tile number
Do
Randomize
intRndRow = Int(Rnd * 4)
intRndCol = Int(Rnd * 4)
blnCheck = True
'By looping through the table
For intCheck = 34 To 49
If Cells(intCheck, 54) = intRndRow * 4 + 1 + intRndCol Then
blnCheck = False
End If
Next intCheck
Loop Until blnCheck = True
'record position of tile
Cells(34 + intLoop, 54) = intRndRow * 4 + 1 + intRndCol
'Copy the numbers for each tile from left to right puzzle
Cells(5 + intRndRow * 6, 32 + intRndCol * 6) = Cells(5 + intLoopRow * 6, 6 + intLoopCol * 6)
Cells(6 + intRndRow * 6, 31 + intRndCol * 6) = Cells(6 + intLoopRow * 6, 5 + intLoopCol * 6)
Cells(6 + intRndRow * 6, 33 + intRndCol * 6) = Cells(6 + intLoopRow * 6, 7 + intLoopCol * 6)
Cells(7 + intRndRow * 6, 32 + intRndCol * 6) = Cells(7 + intLoopRow * 6, 6 + intLoopCol * 6)
intLoop = intLoop + 1
Next intLoopCol
Next intLoopRow
End Sub
This results into the following. The first figure in the BB column indicates that tile 7 is the tile to be placed in position 1 in the top left corner.
The left puzzle should now be cleared.
Sub ClearLeftTiles()
Dim intLoop As Integer
For intLoop = 5 To 25 Step 2
Range(Cells(intLoop, 5), Cells(intLoop, 25)).ClearContents
Range(Cells(5, intLoop), Cells(25, intLoop)).ClearContents
Next intLoop
End Sub
To nominate which tile to place in what position we'll place a procedure in the Sheet1 (Tilexcel) code window. The tile numbers have to be added to the centers of the tiles and the backgrounds have to be yellow.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
'Check if a cell is selected on right
If Not Intersect(Target, Range("$AF$6:$AX$24")) Is Nothing Then
'Check if the background is yellow
If Target.Interior.Color = vbYellow Then
'Place the number into the right placement box
[AM32] = Target.Value
End If
End If
'Check if a cell is selected on left
If Not Intersect(Target, Range("$F$6:$X$24")) Is Nothing Then
'Check if the background is yellow
If Target.Interior.Color = vbYellow Then
'Place the number into the left placement box
[M32] = Target.Value
End If
End If
End Sub
Here is a tile number to be transferred placed into the right cell or box which is AM32.
To be able to now place the tile into the left puzzle requires working with row and column numbers. There is a table to show the rows and columns where the right tiles are located in columns 56 and 57 which are BD and BE starting in row 34.
We'll record dynamically where left tiles are located in column BA (53). The correct tile was placed in column 54 or BB in the procedure further above.
The tile number in column 55 gives the row number where to find the location of a tile in the right block. The rows are the same for the left tile block but the columns are 26 to the left.
In the picture below I have placed tile 3 from the tiles on the right in position 12 on the left but the correct tile would be tile 6.
Now it is possible to place a tile from the right pool into a position in the left puzzle.
Sub PlaceTile()
If Cells(48, 7) = "Completed :-)" Then Exit Sub
Dim intRowRight As Integer
Dim intColRight As Integer
Dim intRowLeft As Integer
Dim intColLeft As Integer
Dim intLoop As Integer
Dim blnSolved As Boolean
'If the tile is already somewhere then clear it
For intLoop = 34 To 49
If Cells(intLoop, 53) = Cells(32, 39) Then
intRowLeft = Cells(33 + intLoop - 33, 56)
intColLeft = Cells(33 + intLoop - 33, 57) - 26
Call ClearTile(intRowLeft, intColLeft)
'Delete it from column 53
Cells(intLoop, 53) = ""
End If
Next intLoop
'Work out where the selected tile is on the right
intRowRight = Cells(33 + Cells(32, 39), 56)
intColRight = Cells(33 + Cells(32, 39), 57)
'Work out where the tile is to be put on the left
intRowLeft = Cells(33 + Cells(32, 13), 56)
'Left tiles are 26 columns from right tiles
intColLeft = Cells(33 + Cells(32, 13), 57) - 26
'record the tile number in column 53
Cells(33 + Cells(32, 13), 53) = Cells(32, 39)
'Place the tile
'Left of cell
Cells(intRowLeft, intColLeft - 1) = Cells(intRowRight, intColRight - 1)
'Right of cell
Cells(intRowLeft, intColLeft + 1) = Cells(intRowRight, intColRight + 1)
'Above cell
Cells(intRowLeft - 1, intColLeft) = Cells(intRowRight - 1, intColRight)
'Below cell
Cells(intRowLeft + 1, intColLeft) = Cells(intRowRight + 1, intColRight)
'check whether all tiles are in the right places
'by comparing column 53 with 54
blnSolved = True
For intLoop = 34 To 49
If Cells(intLoop, 53) <> Cells(intLoop, 54) Then
blnSolved = False
End If
Next intLoop
If blnSolved Then
Cells(48, 7) = "Completed :-)"
' ShowFace
End If
End Sub
Here is the procedure to clear a tile.
Sub ClearTile(intRow As Integer, intCol As Integer)
'Clear numbers from tile
'Left of cell
Cells(intRow, intCol - 1) = ""
'Right of cell
Cells(intRow, intCol + 1) = ""
'Above cell
Cells(intRow - 1, intCol) = ""
'Below cell
Cells(intRow + 1, intCol) = ""
'Cells(37, 37).Select
End Sub
The game should be set up straight after loading. This goes into the ThisWorkbook code area.
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Setup
Application.ScreenUpdating = True
End Sub
Back to the Module
Sub Setup()
Application.ScreenUpdating = False
SetupLeftTiles
TransferTilesRandomlyToRight
ClearLeftTiles
'HideFace
Cells(37, 37).Select
Application.ScreenUpdating = True
End Sub
Since a lot of the code is already there we can easily add a button to clear a tile on the left.
Sub ClearThisTile()
If Cells(48, 7) = "Completed :-)" Then Exit Sub
Dim intRowLeft As Integer
Dim intColLeft As Integer
'Work out from the table where the tile to be cleared is on the left
intRowLeft = Cells(33 + Cells(32, 13), 56)
intColLeft = Cells(33 + Cells(32, 13), 57) - 26
Call ClearTile(intRowLeft, intColLeft)
'Clear the record in the table
Cells(33 + Cells(32, 13), 53) = ""
End Sub
It may save time to move a tile.
Sub MoveTileRight()
Select Case Cells(32, 13)
Case 4, 8, 12, 16
'It's already on the edge
Exit Sub
End Select
'Move the tile numbers to the right
Call MoveTile(0, 6)
'Move the record for the tile one down in column 53
MoveRecord (1)
End Sub
This requires 2 more subroutines.
Sub MoveTile(intRowMove As Integer, intColMove As Integer)
If Cells(48, 7) = "Completed :-)" Then Exit Sub
Dim intRow As Integer
Dim intCol As Integer
'Find the position of the cell to the left of the numbered cell
intRow = Cells(33 + Cells(32, 13), 56)
intCol = Cells(33 + Cells(32, 13), 57) - 26 - 1
'Copy tile numbers to new tile
'This left cell
Cells(intRow + intRowMove, intCol + intColMove) = Cells(intRow, intCol)
'Right cell = column + 2
Cells(intRow + intRowMove, intCol + intColMove + 2) = Cells(intRow, intCol + 2)
'Above centre cell = row - 1 & column + 1
Cells(intRow + intRowMove - 1, intCol + intColMove + 1) = Cells(intRow - 1, intCol + 1)
'Below centre cell = row + 1 & column + 1
Cells(intRow + intRowMove + 1, intCol + intColMove + 1) = Cells(intRow + 1, intCol + 1)
'Clear the current tile
Call ClearTile(intRow, intCol + 1)
End Sub
and
Sub MoveRecord(intMove As Integer)
'Move the record for the tile in column 53
Cells(33 + Cells(32, 13) + intMove, 53) = Cells(33 + Cells(32, 13), 53)
'Clear the record for the original tile in column 53
Cells(33 + Cells(32, 13), 53) = ""
End Sub
The tile is to move left.
Sub MoveTileLeft()
Select Case Cells(32, 13)
Case 1, 5, 9, 13
'It's already on the edge
Exit Sub
End Select
'Move the tile numbers to the left
Call MoveTile(0, -6)
'Move the record for the tile one up in column 53
MoveRecord (-1)
End Sub
Sub MoveTileUp()
Select Case Cells(32, 13)
Case 1, 2, 3, 4
'Already at the top
Exit Sub
End Select
'Move the tile numbers up
Call MoveTile(-6, 0)
'Move the record for the tile four up in column 53
MoveRecord (-4)
End Sub
Sub MoveTileDown()
Select Case Cells(32, 13)
Case 13, 14, 15, 16
'Already at the bottom
Exit Sub
End Select
'Move the tile numbers down
Call MoveTile(6, 0)
'Move the record for the tile four down in column 53
MoveRecord (4)
End Sub
Here is the code for the face to appear when the game is over.
Sub ShowFace()
Dim intTransparency As Integer
Dim dblDelay As Double
Dim dblStartTime As Double
'Run this once then Rem it again
'ActiveSheet.Shapes.AddShape(msoShapeSmileyFace, 220, 320, 156.75, 149.25).Name = "Face"
With ActiveSheet.Shapes("Face")
.Visible = True
.Fill.ForeColor.SchemeColor = 3
For intTransparency = 100 To 1 Step -2
.Fill.Transparency = intTransparency / 100
.Line.Transparency = intTransparency / 100
dblDelay = 0.00001
dblStartTime = Timer
Do
DoEvents
Loop While Timer - dblStartTime < dblDelay
Next intTransparency
End With
End Sub
Here is the code to hide the face.
Sub HideFace()
ActiveSheet.Shapes("Face").Visible = False
ActiveSheet.Shapes("Face").Fill.Transparency = 1
ActiveSheet.Shapes("Face").Line.Transparency = 1
End Sub
If it's too hard then click the Hint button.
Sub Hint()
If Cells(48, 7) = "Completed :-)" Then Exit Sub
'Increment hint count
Cells(50, 53) = Cells(50, 53) + 1
'Show the first/next hint
Cells(48, 7) = "Tile " & Cells(50, 53) & " is Tile " & Cells(33 + Cells(50, 53), 54)
End Sub