Redback
In this game move the numbers so that they descend from 13 down to 1. To do this select the number to be moved, then hold down Ctrl and select an empty cell with a number above one higher than the cell to be moved. Click the Move Cell(S) button.
It's possible to move more than on cell. Here I've moved the 11 and 10 in one operation.
The yellow boxes are Rectangles, the top 3 of which run macros.
There are some global variables required.
Option Explicit
Public Numbers(103) As Integer
Public intCellsUsed As Integer
Public blnFinished As Boolean
We have to arrange 8 suits of 13 to 1 stacks which equates to 104 numbers in total.
Start with the New button.
Sub NewGame()
Dim intRnd As Integer
Dim intTemp As Integer
Dim intRow As Integer
Dim intCol As Integer
Range("A2:J50").ClearContents
intCellsUsed = 0
blnFinished = False
Randomize
'Fill the array
For intRow = 1 To 13
For intCol = 1 To 8
Numbers(intCellsUsed) = intRow
intCellsUsed = intCellsUsed + 1
Next intCol
Next intRow
'Shuffle the array
For intCellsUsed = 0 To 103
intRnd = Int(103 * Rnd) + 1
intTemp = Numbers(intRnd)
Numbers(intRnd) = Numbers(intCellsUsed)
Numbers(intCellsUsed) = intTemp
Next intCellsUsed
'Display initial numbers
intCellsUsed = 0
For intRow = 2 To 6
For intCol = 1 To 10
Cells(intRow, intCol) = Numbers(intCellsUsed)
intCellsUsed = intCellsUsed + 1
Next intCol
Next intRow
For intCol = 1 To 4
Cells(intRow, intCol) = Numbers(intCellsUsed)
intCellsUsed = intCellsUsed + 1
Next intCol
'Show how many times Add Numbers is still to be clicked.
[L8] = 5
End Sub
I added a routine just after the Dims to guard against accidentally clicking the New button.
If Not blnFinished Then
If MsgBox("Start new game?", vbYesNo, "New game") = vbNo Then Exit Sub
End If
A number of checks are in the MoveCells procedure to ensure the move is legal.
Sub MoveCells()
If blnFinished Then Exit Sub
Dim cell As Range
Dim intCell As Integer
Dim strCell_1 As String
Dim strCell_2 As String
Dim intRow_1 As Integer
Dim intRow_2 As Integer
Dim intCol_1 As Integer
Dim intCol_2 As Integer
Dim intNum_1 As Integer
Dim intNum_2 As Integer
Dim intRows As Integer
Dim intRow As Integer
Dim intCol As Integer
intCell = 1
If Selection.Cells.Count <> 2 Then
MsgBox "Please select 2 cells."
Exit Sub
End If
'Record the details of each cell selected
For Each cell In Selection.Cells
If intCell = 1 Then
strCell_1 = cell.Address
intRow_1 = Range(strCell_1).Row
intCol_1 = Range(strCell_1).Column
intNum_1 = Range(strCell_1).Value
Else
strCell_2 = cell.Address
intRow_2 = Range(strCell_2).Row
intCol_2 = Range(strCell_2).Column
intNum_2 = Range(strCell_2).Value
End If
intCell = 2
Next cell
'Exit if illegal moves
If Range(strCell_1) = "" Then
MsgBox "First cell can't be empty"
Exit Sub
End If
If Range(strCell_2).Value <> 0 Then
MsgBox "Second cell must be empty"
Exit Sub
End If
If intRow_2 <> 2 Then
If intNum_1 <> Cells(intRow_2 - 1, intCol_2) - 1 Then
MsgBox "Cell value of " & Cells(intRow_2 - 1, intCol_2).Address _
& " above Target cell must be " & intNum_1 + 1
Exit Sub
End If
End If
intCell = 0
Do
intCell = intCell + 1
If Cells(intRow_1 + intCell, intCol_1) <> "" Then
If Cells(intRow_1 + intCell, intCol_1) + 1 _
<> Cells(intRow_1 + intCell - 1, intCol_1) Then
MsgBox "Cell values are not descending."
Exit Sub
End If
End If
Loop Until Cells(intRow_1 + intCell, intCol_1) = ""
'Move the cells
intRow = 0
For intRows = intRow_1 To intRow_1 + intCell
Cells(intRow_2 + intRow, intCol_2) = Cells(intRow_1 + intRow, intCol_1)
Cells(intRow_1 + intRow, intCol_1) = ""
intRow = intRow + 1
Next intRows
'Check whether column of 13 can be deleted
'Add the Call once the Sub is written
Call CheckFor13(intRow_2 + intRow - 2, intCol_2)
'Is the game finished?
blnFinished = True
For intCol = 1 To 10
If Cells(2, intCol) <> "" Then
blnFinished = False
End If
Next intCol
If blnFinished Then
For intCol = 1 To 10
Cells(4, intCol) = Mid("*Finished*", intCol, 1)
Cells(6, intCol) = Mid("Well Done!", intCol, 1)
Next intCol
End If
End Sub
Since I use Ctrl to select the second cell I added a shortcut to the MoveCells procedure.
Press Alt + F8, select the procedure, then Options, and press Shift + X. So, straight after holding down Ctrl to select the second cell I press Ctrl + Shift + X to move the cell(s).
It didn't take long to get used to and to become fluid and quite fast. For a better look add this line just before the End If above.
Range("A1").Select
We'd better delete any completed stacks!
Sub CheckFor13(intCheckRow As Integer, intCheckCol As Integer)
Dim intLoop As Integer
Dim intRow As Integer
If Cells(intCheckRow, intCheckCol) <> 1 Then Exit Sub
For intLoop = intCheckRow - 1 To 2 Step -1
If Cells(intLoop, intCheckCol) <> Cells(intLoop + 1, intCheckCol) + 1 Then Exit Sub
If Cells(intLoop, intCheckCol) = 13 Then
MsgBox "Removing column of 13."
For intRow = intCheckRow To intLoop Step -1
Cells(intRow, intCheckCol) = ""
Next intRow
End If
Next intLoop
End Sub
Which brings me to the last procedure.
Sub AddNumbers()
If blnFinished Then Exit Sub
Dim intRow As Integer
Dim intCol As Integer
Dim intCells As Integer
'Exit if there is a vacant first spot in row 2
For intCol = 1 To 10
If Cells(2, intCol) = "" Then
MsgBox "Fill the empty row 2 cell(s)"
Exit Sub
End If
Next intCol
For intCol = 1 To 10
intCells = 0
For intRow = 2 To 50
If Cells(intRow, intCol) = "" Then
intCells = intCells + 1
If intCells = 11 Then Exit Sub
If intCellsUsed > 103 Then Exit Sub
Cells(intRow, intCol) = Numbers(intCellsUsed)
'If it's a 1 then check whether 13 can be deleted
Call CheckFor13(intRow, intCol)
intCellsUsed = intCellsUsed + 1
Exit For
End If
Next intRow
Next intCol
[L8] = [L8] - 1
End Sub
There are some global variables required.
Option Explicit
Public Numbers(103) As Integer
Public intCellsUsed As Integer
Public blnFinished As Boolean
We have to arrange 8 suits of 13 to 1 stacks which equates to 104 numbers in total.
Start with the New button.
Sub NewGame()
Dim intRnd As Integer
Dim intTemp As Integer
Dim intRow As Integer
Dim intCol As Integer
Range("A2:J50").ClearContents
intCellsUsed = 0
blnFinished = False
Randomize
'Fill the array
For intRow = 1 To 13
For intCol = 1 To 8
Numbers(intCellsUsed) = intRow
intCellsUsed = intCellsUsed + 1
Next intCol
Next intRow
'Shuffle the array
For intCellsUsed = 0 To 103
intRnd = Int(103 * Rnd) + 1
intTemp = Numbers(intRnd)
Numbers(intRnd) = Numbers(intCellsUsed)
Numbers(intCellsUsed) = intTemp
Next intCellsUsed
'Display initial numbers
intCellsUsed = 0
For intRow = 2 To 6
For intCol = 1 To 10
Cells(intRow, intCol) = Numbers(intCellsUsed)
intCellsUsed = intCellsUsed + 1
Next intCol
Next intRow
For intCol = 1 To 4
Cells(intRow, intCol) = Numbers(intCellsUsed)
intCellsUsed = intCellsUsed + 1
Next intCol
'Show how many times Add Numbers is still to be clicked.
[L8] = 5
End Sub
I added a routine just after the Dims to guard against accidentally clicking the New button.
If Not blnFinished Then
If MsgBox("Start new game?", vbYesNo, "New game") = vbNo Then Exit Sub
End If
A number of checks are in the MoveCells procedure to ensure the move is legal.
Sub MoveCells()
If blnFinished Then Exit Sub
Dim cell As Range
Dim intCell As Integer
Dim strCell_1 As String
Dim strCell_2 As String
Dim intRow_1 As Integer
Dim intRow_2 As Integer
Dim intCol_1 As Integer
Dim intCol_2 As Integer
Dim intNum_1 As Integer
Dim intNum_2 As Integer
Dim intRows As Integer
Dim intRow As Integer
Dim intCol As Integer
intCell = 1
If Selection.Cells.Count <> 2 Then
MsgBox "Please select 2 cells."
Exit Sub
End If
'Record the details of each cell selected
For Each cell In Selection.Cells
If intCell = 1 Then
strCell_1 = cell.Address
intRow_1 = Range(strCell_1).Row
intCol_1 = Range(strCell_1).Column
intNum_1 = Range(strCell_1).Value
Else
strCell_2 = cell.Address
intRow_2 = Range(strCell_2).Row
intCol_2 = Range(strCell_2).Column
intNum_2 = Range(strCell_2).Value
End If
intCell = 2
Next cell
'Exit if illegal moves
If Range(strCell_1) = "" Then
MsgBox "First cell can't be empty"
Exit Sub
End If
If Range(strCell_2).Value <> 0 Then
MsgBox "Second cell must be empty"
Exit Sub
End If
If intRow_2 <> 2 Then
If intNum_1 <> Cells(intRow_2 - 1, intCol_2) - 1 Then
MsgBox "Cell value of " & Cells(intRow_2 - 1, intCol_2).Address _
& " above Target cell must be " & intNum_1 + 1
Exit Sub
End If
End If
intCell = 0
Do
intCell = intCell + 1
If Cells(intRow_1 + intCell, intCol_1) <> "" Then
If Cells(intRow_1 + intCell, intCol_1) + 1 _
<> Cells(intRow_1 + intCell - 1, intCol_1) Then
MsgBox "Cell values are not descending."
Exit Sub
End If
End If
Loop Until Cells(intRow_1 + intCell, intCol_1) = ""
'Move the cells
intRow = 0
For intRows = intRow_1 To intRow_1 + intCell
Cells(intRow_2 + intRow, intCol_2) = Cells(intRow_1 + intRow, intCol_1)
Cells(intRow_1 + intRow, intCol_1) = ""
intRow = intRow + 1
Next intRows
'Check whether column of 13 can be deleted
'Add the Call once the Sub is written
Call CheckFor13(intRow_2 + intRow - 2, intCol_2)
'Is the game finished?
blnFinished = True
For intCol = 1 To 10
If Cells(2, intCol) <> "" Then
blnFinished = False
End If
Next intCol
If blnFinished Then
For intCol = 1 To 10
Cells(4, intCol) = Mid("*Finished*", intCol, 1)
Cells(6, intCol) = Mid("Well Done!", intCol, 1)
Next intCol
End If
End Sub
Since I use Ctrl to select the second cell I added a shortcut to the MoveCells procedure.
Press Alt + F8, select the procedure, then Options, and press Shift + X. So, straight after holding down Ctrl to select the second cell I press Ctrl + Shift + X to move the cell(s).
It didn't take long to get used to and to become fluid and quite fast. For a better look add this line just before the End If above.
Range("A1").Select
We'd better delete any completed stacks!
Sub CheckFor13(intCheckRow As Integer, intCheckCol As Integer)
Dim intLoop As Integer
Dim intRow As Integer
If Cells(intCheckRow, intCheckCol) <> 1 Then Exit Sub
For intLoop = intCheckRow - 1 To 2 Step -1
If Cells(intLoop, intCheckCol) <> Cells(intLoop + 1, intCheckCol) + 1 Then Exit Sub
If Cells(intLoop, intCheckCol) = 13 Then
MsgBox "Removing column of 13."
For intRow = intCheckRow To intLoop Step -1
Cells(intRow, intCheckCol) = ""
Next intRow
End If
Next intLoop
End Sub
Which brings me to the last procedure.
Sub AddNumbers()
If blnFinished Then Exit Sub
Dim intRow As Integer
Dim intCol As Integer
Dim intCells As Integer
'Exit if there is a vacant first spot in row 2
For intCol = 1 To 10
If Cells(2, intCol) = "" Then
MsgBox "Fill the empty row 2 cell(s)"
Exit Sub
End If
Next intCol
For intCol = 1 To 10
intCells = 0
For intRow = 2 To 50
If Cells(intRow, intCol) = "" Then
intCells = intCells + 1
If intCells = 11 Then Exit Sub
If intCellsUsed > 103 Then Exit Sub
Cells(intRow, intCol) = Numbers(intCellsUsed)
'If it's a 1 then check whether 13 can be deleted
Call CheckFor13(intRow, intCol)
intCellsUsed = intCellsUsed + 1
Exit For
End If
Next intRow
Next intCol
[L8] = [L8] - 1
End Sub
