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