Excel Sudoku
Here is a Sudoku game in Excel. It creates the puzzle reasonably fast as it's written, as usual, with Rudimentary but easy to understand code.
During development I had to stop Excel a few times with the Task Manager when it went into an endless loop. So, make sure to save the file before running the game!
Let's start by laying out the grid. Name the sheet Puzzle. Then copy it and name the copy Solution. The Solution sheet only uses down to row 10, the rest can be deleted.
Here is a Sudoku game in Excel. It creates the puzzle reasonably fast as it's written, as usual, with Rudimentary but easy to understand code.
During development I had to stop Excel a few times with the Task Manager when it went into an endless loop. So, make sure to save the file before running the game!
Let's start by laying out the grid. Name the sheet Puzzle. Then copy it and name the copy Solution. The Solution sheet only uses down to row 10, the rest can be deleted.
It shows candidates in row 15 for a cell as it's selected. Hit the Candies button and we'll hide the candidates or bring them back.
Option Explicit
Sub ShowHideCandies()
'Simplified
Range("D15").EntireRow.Hidden = Not Range("D15").EntireRow.Hidden
End Sub
Now we'll create a New Puzzle.
Sub CreatePuzzle()
Dim intRow As Integer
Dim intColumn As Integer
Dim intLoop As Integer
Dim intRnd As Integer
Dim blnOK As Boolean
Dim intEnd As Integer
Dim intFinish As Integer
'Delay loop or ScreenUpdating appears to set to False too quick
For intLoop = 1 To 10
Range("A1 : J10") = ""
Range("A1 : J10").Font.Color = vbBlack
Next intLoop
Application.ScreenUpdating = False
'If puzzle is stuck then start again from here
StartHere:
'Counter for starting again
intFinish = 0
Randomize
For intRow = 2 To 10
'Try each row up to 20 times from here
TryFromHere:
'If this puzzle does not work then go to the beginning again
If intFinish > 20 Then GoTo StartHere
'Clear the row as it may be another attempt
Range(Cells(intRow, 2), Cells(intRow, 10)) = ""
For intColumn = 2 To 10
'Counter for abandoning the row
intEnd = 0
Do
'Random number 1 to 9
intRnd = Int(Rnd * 9 + 1)
'Set OK to place into cell
blnOK = True
'Is the number in the block of 9 cells?
'Unrem this when the function is written
'blnOK = Not funcCheck3x3(intRow, intColumn, intRnd)
'Check along the row and the column
For intLoop = 2 To 10
If Cells(intRow, intLoop) = intRnd _
Or Cells(intLoop, intColumn) = intRnd Then
blnOK = False
End If
Next intLoop
'Increment counter to start row again
intEnd = intEnd + 1
'If row is not OK after 20 tries then start row again
If intEnd = 20 Then
'Increment counter to start from the beginning
intFinish = intFinish + 1
'Start row again
GoTo TryFromHere
End If
Loop Until blnOK
'It's OK, so put the number into the cell
Cells(intRow, intColumn) = intRnd
Next intColumn
Next intRow
'Copy numbers to Solution sheet
Worksheets("Solution").Range("A2 : J10").Value _
= Worksheets("Puzzle").Range("A2 : J10").Value
'More to come
'Fire the Candies proc
Range("F7").Select
Range("F6").Select
End Sub

That's not quite correct as there are duplicate numbers in the blocks of nine. Here is the function to check for those.
Function funcCheck3x3(ByVal iRow As Integer, ByVal iCol As Integer, iRnd As Integer) As Boolean
'Check whether the number is already in block of 9
Dim intR As Integer
Dim intC As Integer
'Find top left cell of the block
'The row
intR = 2
If iRow > 4 Then intR = 5
If iRow > 7 Then intR = 8
'The column
intC = 2
If iCol > 4 Then intC = 5
If iCol > 7 Then intC = 8
'Cycle through the block
For iRow = intR To intR + 2
For iCol = intC To intC + 2
If Cells(iRow, iCol) = iRnd Then funcCheck3x3 = True
'The number is already there
Next iCol
Next iRow
End Function
Now unrem the function call in the CreatePuzzle procedure.
That gives us the numbers for the puzzle but not the means of playing a game. For this we must hide some numbers. The more number are hidden the harder it is to rediscover them again.
To select the amount of numbers to hide I've put a validation list into cell I13. The list is on the Solution sheet at B12:B18.
In I12 on the Puzzle sheet was Clear or you might like to have appropriate text to describe the task.
=VLOOKUP(I13,Solution!B12:C18,2)
Here is the code to add to the CreatePuzzle procedure to hide random cells.
'More to come - you can delete me now
'Erase some numbers according to users' choice in I13
For intLoop = 1 To Range("I13")
Do
intRow = Int(Rnd * 9 + 2)
intColumn = Int(Rnd * 9 + 2)
Loop Until Cells(intRow, intColumn) <> ""
Cells(intRow, intColumn) = ""
Next intLoop
The Check button can be used to find out whether any numbers entered are incorrect. It races through the cells on the Solution sheet comparing them with the Puzzle sheet cells.
Sub Check()
'Show incorrect numbers in red on puzzle sheet
Dim intRow As Integer
Dim intColumn As Integer
'Erase any previous red numbers
Range("B2:J10").Font.Color = vbBlack
For intRow = 2 To 10
For intColumn = 2 To 10
If Cells(intRow, intColumn) <> "" Then
If Cells(intRow, intColumn) <> Worksheets("Solution").Cells(intRow, intColumn) Then
Cells(intRow, intColumn).Font.Color = vbRed
End If
End If
Next intColumn
Next intRow
End Sub
This is handy as there can sometimes be more than one solution although only one correct solution. In this example four cells can be a 4 or an 8. The red cell in this case is a 4.
Next is the Candidates procedure. You can leave it if you prefer but it is used for another option later on. It will run every time a puzzle cell is selected.
Sub Candidates()
Dim intCandidate As Integer
Dim intLoop As Integer
Dim blnYes As Boolean
'Clear the candidates when a number is in the cell and exit
If ActiveCell <> "" Then
Range("B15:J15") = ""
Exit Sub
End If
'Check whether number is present somewhere
For intCandidate = 1 To 9
'Check block of 9 cells
blnYes = funcCheck3x3(ActiveCell.Row, ActiveCell.Column, intCandidate)
For intLoop = 2 To 10 'column and row number
'Check along row
If Cells(ActiveCell.Row, intLoop) = intCandidate Then blnYes = True
'Check down column
If Cells(intLoop, ActiveCell.Column) = intCandidate Then blnYes = True
Next intLoop
If blnYes Then
'Not this candidate as number is already somewhere
Cells(15, intCandidate + 1) = ""
Else
'Number not in row, column or block so show candidate
Cells(15, intCandidate + 1) = intCandidate
End If
'Reset flag for next candidate
blnYes = False
Next intCandidate
End Sub
To get this to kick in, double click Sheet1 (Puzzle) in the Project Explorer then click Worksheet in the Combo box, as shown below, and add the following.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Keep the cursor in the puzzle or Clear cell
If Intersect(Target, Range("B2:J10")) Is Nothing _
And Intersect(Target, Range("I13")) Is Nothing Then
Range("F6").Select
End If
Candidates
End Sub
This procedure is now called every time another cell is selected.
Remember that the candidates can be hidden even if the above is added.
If it's time to give up on a puzzle then hit the Solve button.
Sub Solve()
'Check and show incorrect numbers in red and fill blanks with green numbers
Dim intRow As Integer
Dim intColumn As Integer
Check
For intRow = 2 To 10
For intColumn = 2 To 10
If Cells(intRow, intColumn) = "" Then
Cells(intRow, intColumn) = Worksheets("Solution").Cells(intRow, intColumn)
Cells(intRow, intColumn).Font.Color = vbGreen
End If
Next intColumn
Next intRow
End Sub
Here is another way to solve the puzzle. Add a new sheet, named Candies, with expanded rows and columns for candidates.
Make a copy called Blank Candies. A copy is going to be grabbed from Blank Candies but only down to row 28.
The NewCandiesPuzzle procedure copies the numbers off the Puzzle sheet. If there is a number then it gets enlarged to the 9 cells of a square. If there isn't a number then it inserts the candidates from the puzzle sheet.
So, to play Sudoku this way hit the New Puzzle button on the Puzzle sheet and then the New Puzzle button on the Candies sheet.
Sub NewCandiesPuzzle()
'This procedure shows either numbers or candidates in cells on the Candies sheet
'by grabbing the data from the Puzzle sheet
'Outer loop variables for main cells on Candies sheet
Dim intRowCandies As Integer
Dim intColumnCandies As Integer
'Inner loop variables for candidates
Dim intCandiesRow As Integer
Dim intCandiesColumn As Integer
'Main cells on Puzzle sheet
Dim intRowPuzzle As Integer
Dim intColumnPuzzle As Integer
'Candidate cells on Puzzle sheet
Dim intPuzzleCandidateColumn As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Load blank sheet
Sheets("Blank Candies").Range("B2:AB28").Copy Sheets("Candies").Range("B2")
'Start in B2 on the Puzzle sheet
intColumnPuzzle = 2
intRowPuzzle = 2
'Cycle through the top left cells on the Candies sheet
For intRowCandies = 2 To 26 Step 3
For intColumnCandies = 2 To 26 Step 3
'Fetch what's in the Puzzle cell
Worksheets("Candies").Cells(intRowCandies, intColumnCandies) _
= Worksheets("Puzzle").Cells(intRowPuzzle, intColumnPuzzle)
'Check whether the cell on the Candies sheet now displays a number
If Worksheets("Candies").Cells(intRowCandies, intColumnCandies) <> "" Then
'Yes, so merge the 9 cell block on the Candies sheet to show a big solved number
Worksheets("Candies").Activate
Range(Cells(intRowCandies, intColumnCandies), Cells(intRowCandies + 2, _
intColumnCandies + 2)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = True
.Font.Size = 30
.RowHeight = 15
End With
Else
'No, so put the candidates in from the puzzle sheet
intPuzzleCandidateColumn = 2
Worksheets("Puzzle").Activate
Cells(intRowPuzzle, intColumnPuzzle).Select
'This fires the Candidates proc
For intCandiesRow = 0 To 2
For intCandiesColumn = 0 To 2
'Place candidates into the 3 x 3 grid on the candies sheet
Worksheets("Candies").Cells(intRowCandies + intCandiesRow, _
intColumnCandies + intCandiesColumn) = _
Worksheets("Puzzle").Cells(15, intPuzzleCandidateColumn)
'from the Puzzle candidates cells in a straight row 15
intPuzzleCandidateColumn = intPuzzleCandidateColumn + 1
Next intCandiesColumn
Next intCandiesRow
End If
'Move the Puzzle cell by 1 column for every 3 on the Candies sheet
intColumnPuzzle = intColumnPuzzle + 1
'Next third column on the Candies sheet
Next intColumnCandies
'Next row on the Puzzle sheet
intRowPuzzle = intRowPuzzle + 1
'Start again with first candidate on the Puzzle sheet
intColumnPuzzle = 2
'Next third row on the Candies sheet
Next intRowCandies
Worksheets("Candies").Select
Application.DisplayAlerts = True
End Sub
So we go from the above to the below. The above candidates are for the bottom right cell.
But there is more to come. When, like before, there are 2 solutions, the Peek button will give the answer before entering the number. Click any of the candidate cells, then the Peek button.
Sub Peek()
Dim intRow As Integer
Dim intCol As Integer
Dim blnDummy As Boolean
intRow = ActiveCell.Row
intCol = ActiveCell.Column
'Find the top left cell of candidates block
TopLeftCell intRow, intCol
'Peek the number from the Solution sheet
Range("Q30") = Worksheets("Solution").Cells((intRow + 1) / 3 + 1, (intCol + 1) / 3 + 1)
End Sub
This is looking for the TopLeftCell procedure which will point intRow and intCol to the top left cell of this number cell. Note that the border formatting, red or black here, has to be thick.
Sub TopLeftCell(iRow As Integer, iCol As Integer)
'Find the top left cell of the 3 x 3 cells on the Puzzle sheet
'or the top left cell of the 3 x 3 candidates on the Candies sheet
'and set the callers intRow and intCol to it
'The blocks of 9 cells must have thick borders
Do
If Cells(iRow, iCol).Borders(xlEdgeLeft).Weight <> xlThick Then
iCol = iCol - 1
End If
Loop Until Cells(iRow, iCol).Borders(xlEdgeLeft).Weight = xlThick
Do
If Cells(iRow, iCol).Borders(xlEdgeTop).Weight <> xlThick Then
iRow = iRow - 1
End If
Loop Until Cells(iRow, iCol).Borders(xlEdgeTop).Weight = xlThick
End Sub
Anytime the numbers entered can be checked for correctness.
Sub CheckCandiesPuzzle()
'Show incorrect numbers in red on Candies sheet
Dim intCandiesRow As Integer
Dim intCandiesColumn As Integer
Dim intSolutionRow As Integer
Dim intSolutionColumn As Integer
intSolutionRow = 2
intSolutionColumn = 2
'Erase any previous red numbers
Range("B2:AB28").Font.Color = vbBlack
'The big font size indicates a solved number is present
For intCandiesRow = 2 To 26 Step 3
For intCandiesColumn = 2 To 26 Step 3
If Cells(intCandiesRow, intCandiesColumn).Font.Size = 30 Then
If Cells(intCandiesRow, intCandiesColumn) _
<> Worksheets("Solution").Cells(intSolutionRow, intSolutionColumn) Then
Cells(intCandiesRow, intCandiesColumn).Font.Color = vbRed
End If
End If
'Increment solution column by 1 for 3 of candies
intSolutionColumn = intSolutionColumn + 1
Next intCandiesColumn
'Increment solution row by 1 for 3 of candies
intSolutionRow = intSolutionRow + 1
'Start with first solution column again
intSolutionColumn = 2
Next intCandiesRow
End Sub
Just like the Puzzle sheet I restrict the cursor to the number squares. Double click Sheet 3 (Candies), then click on worksheet in the top left Combo Box.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Keep the cursor in the Candies puzzle
If Intersect(Target, Range("B2:AB28")) Is Nothing Then
Range("Q14").Select
End If
End Sub
Now comes with my version of entering the number. With the cursor in the SelectionChange procedure select BeforeDoubleClick in the top right Combo Box.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
AssignNumberToCell
End Sub
In a Module add the procedure AssignNumberToCell. It could be added to the above proc.
Option Explicit
Sub AssignNumberToCell()
'Expand double clicked number to the 9 cells
Dim intRow As Integer
Dim intCol As Integer
Dim intR As Integer
Dim intC As Integer
Dim intValue As Integer
Dim intLoop As Integer
intValue = ActiveCell
'Exit if blank candidate cell clicked
If intValue < 1 Then Exit Sub
intRow = ActiveCell.Row
intCol = ActiveCell.Column
'Find the top left cell of candidates
TopLeftCell intRow, intCol
'Select all the candidate cells of this main cell
Range(Cells(intRow, intCol), Cells(intRow + 2, intCol + 2)).Select
'Merge Cells and assign Number
Application.DisplayAlerts = False
Selection.Merge
Selection = intValue
Selection.Font.Size = 30
Selection.Font.Bold = True
'Delete this candidate
End Sub
Now a double click of a candidate places the number. Don't blame me for any strain injury though. Here is the the final part.
'Delete this candidate
'along the 3 rows of the cell
For intR = intRow To intRow + 2
For intC = 2 To 28
If Cells(intR, intC) = intValue And _
Cells(intR, intC).Font.Size = 13 Then
Cells(intR, intC) = ""
End If
Next intC
Next intR
'down the 3 cols of the cell
For intC = intCol To intCol + 2
For intR = 2 To 28
If Cells(intR, intC) = intValue And _
Cells(intR, intC).Font.Size = 13 Then
Cells(intR, intC) = ""
End If
Next intR
Next intC
'in black bordered block of cells
'Find top left corner of block
intR = 2
If intRow > 10 Then intR = 11
If intRow > 19 Then intR = 20
intC = 2
If intCol > 10 Then intC = 11
If intCol > 19 Then intC = 20
'Delete candidate in block
For intRow = intR To intR + 8
For intCol = intC To intC + 8
If Cells(intRow, intCol) = intValue And _
Cells(intRow, intCol).Font.Size = 13 Then
Cells(intRow, intCol) = ""
End If
Next intCol
Next intRow
Application.DisplayAlerts = True
End Sub
How about a bit of color?
I hope you enjoy this game and the programming.
Best wishes,
Rudi
PS
For a programming exercise I thought I'd add the ability to click a candidate to insert it into a puzzle cell. To do this I've added nine TextBoxes to sit over the candidate cells. I started with Buttons but found the font a bit flakey.
Name them TextBox 1 to TextBox 9 in the Name box as shown. This enables looping through the TextBoxes like an array.
We now need to change the code to interact with the candidate TextBoxes instead of the candidate cells. There are 2 modifications in the Candidates procedure.
Sub Candidates()
'Clear the candidates when a number is in the cell and exit
If ActiveCell <> "" Then
For intLoop = 1 To 9
ActiveSheet.TextBoxes("TextBox" & Str(intLoop)).Text = ""
Next intLoop
Exit Sub
End If
and:
If blnYes Then
'Not this candidate as number is already somewhere
ActiveSheet.TextBoxes("TextBox" & Str(intCandidate)).Text = ""
Else
'Number not in row, column or block so show candidate
ActiveSheet.TextBoxes("TextBox" & Str(intCandidate)).Text = intCandidate
End If
Note that "TextBox" & Str(intLoop) results as "TextBox 1".
The next change is when inserting candidates on the Candies sheet. I've changed the variable name from intPuzzleCandidateColumn to intTextBox to reflect the switch from cells to TextBoxes.
Sub NewCandiesPuzzle()
'Candidate TextBoxes along puzzle row 15
Dim intTextBox As Integer
'No, so put the candidates in instead
intTextBox = 1
and:
For intCandiesColumn = 0 To 2
'Place into a 3 x 3 grid
Worksheets("Candies").Cells(intRowCandies + intCandiesRow, _
intColumnCandies + intCandiesColumn) = _
Worksheets("Puzzle").TextBoxes("TextBox" & Str(intTextBox)).Text
'the candidates from puzzle sheet TextBoxes
intTextBox = intTextBox + 1
Next intCandiesColumn
We need a new macro that all the TextBoxes will call.
Sub InsertNumber()
'Check that the TextBox clicked displays a number
If Sheet1.TextBoxes(Application.Caller).Text <> "" Then
'It does so put that number into the cell
ActiveCell = Right(Application.Caller, 1)
End If
End Sub
Now select all the candidate TextBoxes and assign the InsertNumber macro to them. I found that I had to select one of the buttons first then I could Ctrl-right click the TextBoxes. Then Ctrl-right click to deselect the button.
This might be handy on a touch screen.
Cheers,
Rudi