Harmonica
Netherlands Tilburg NoordBrabant
Keep your lovin' brother happy!

Introduction
Last months I solve one medium difficult Sudoku on a daily base to keep my cognitive abilities in shape. Now last week I caught a cold and fell ill. Flu! Instead of boring myself at home I thought, "Lets make a Sudoku Solver in MSExcel". Below is the result. Follow the instructions below and have fun. Maybe you'll learn something!
Disclaimer * The VBAcode is free of virusses, including my fluvirus, which is sad, since I would like to share that with the whole community. * The Sudoku Solver should solve all easy and medium level Sudokus. * It should solve many of the difficult level Sudokus as well. * The Sudoku Solver could only solve Sudokus with one single sollution! * One solving sollution mechanism is lacking, because that is way complex to program. Maybe next year, when I fell ill, I will program it. I will illustrate the lacking mechanism with an example. If two squares only could contain 4s and 8s the other seven squares couldn't contain those values. Simular mechanisms could theoretically also exist in combinations of 3 or more. If someone sees the challenge to program it ... go ahead and make my day! * If you are stuck with finding a sollution, trial and error in the Solvergrid to come to the right sollution. Eventually you should restart a few times. * It should be easy to handle the Sudoku Solver. * Feel free to adjust the Sudoku Solver. Have fun!
Instruction * Font of the whole sheet is Arial. * Cell A1: "Sudoku Solver", 18pt, Bold * Cell A2: "Author: Harmonica", 11pt, Italic * Cell A3: "Date: 4 November 2017", 11pt, Italic * Cell B7: "Sudoku", 14pt, Bold * Cell L7: "Solver", 14pt, Bold * Cell L20: "Round:", 11pt Italic * Cell N20: "(0=Reset)", 11pt * Cell L21: "Note:", 11pt * Cell M20: 11pt * Cell M21: 11pt * Cells B9J17: 16pt, Bold with borders * Cells B39J47: 16pt, Bold with borders * Cells L9T17: 10pt, Bold with borders * Columns BJ: Width=4 * Columns LT: Width=10 * CopyPaste the VBACode to a VBA Module. It won't work otherwise. The easiest way to create a module is to Record a Macro, Type Some Text and Stop the Recording. * In Excel you need to activate the Developers tab. * Create below the Sudoku 5 Buttons with the captions "Solve One Round", "Save Sudoku", "Restore Sudoku", "Random Value" and "Clear Sudoku", 12pt, Bold. * Apply the right Macro to the right Button. * Save your work and try it.
Visual Basic for Applications Code
Option Explicit
Sub SolveOneRound() Dim intRow As Integer Dim intCol As Integer Dim intNbr As Integer Dim intNbrCount As Integer Dim intSqr As Integer Dim intSqrRow As Integer Dim intSqrCol As Integer Dim blnChange As Boolean Dim intRound As Integer Dim strMsg As String Dim blnCheck As Boolean Dim strSlvOld As String Dim strSlvNew As String Dim intStr As Integer Dim intSlvRow As Integer Dim intSlvCol As Integer Dim intSqrSlvRow As Integer Dim intSqrSlvCol As Integer Dim strSlv As String Dim blnSlvFound As Boolean Dim intRowSlvFound As Integer Dim intColSlvFound As Integer Dim intSqrSlvFound As Integer
Application.ScreenUpdating = False blnChange = False strMsg = "" If IsNumeric(Cells(20, 13).Value) Then intRound = Cells(20, 13).Value If intRound < 0 Then strMsg = strMsg & "Value Round is not a positive numeric value. " End If Else strMsg = strMsg & "Value Round is not numeric. " End If
'Reset Sudoku and Solver If intRound = 0 Then Columns("B:J").ColumnWidth = 4 Columns("L:T").ColumnWidth = 10
For intCol = 2 To 10 For intRow = 9 To 17 If IsEmpty(Cells(intRow, intCol).Value) Then Cells(intRow, intCol).Value = "" End If
If IsNull(Cells(intRow, intCol).Value) Then Cells(intRow, intCol).Value = "" End If
If Cells(intRow, intCol).Value = "" Then Cells(intRow, intCol).Font.Color = RGB(125, 125, 125) Else Cells(intRow, intCol).Font.Color = RGB(0, 0, 0) End If Next intRow Next intCol
For intCol = 12 To 20 For intRow = 9 To 17 Cells(intRow, intCol).Value = "123456789" Next intRow Next intCol End If 'Check Sudoku blnCheck = True For intCol = 2 To 10 For intRow = 9 To 17 If Not IsNumeric(Cells(intRow, intCol).Value) And Cells(intRow, intCol).Value <> "" Then blnCheck = False Else If (Cells(intRow, intCol).Value < 1 Or Cells(intRow, intCol).Value > 9) And Cells(intRow, intCol).Value <> "" Then blnCheck = False End If End If Next intRow Next intCol If Not blnCheck Then strMsg = strMsg & "Sudoku does not contain only empty or numeric values from 1 to 9. " End If 'Check Solver blnCheck = True For intCol = 12 To 20 For intRow = 9 To 17 If Not IsNumeric(Cells(intRow, intCol).Value) Or Cells(intRow, intCol).Value = "" Then blnCheck = False End If Next intRow Next intCol If Not blnCheck Then strMsg = strMsg & "Solver does not contain only numeric values. " End If 'Check Sudoku Integrity blnCheck = True For intNbr = 1 To 9 For intCol = 2 To 10 intNbrCount = 0 For intRow = 9 To 17 If Cells(intRow, intCol).Value = intNbr Then intNbrCount = intNbrCount + 1 End If Next intRow If intNbrCount > 1 Then strMsg = strMsg & "Number " & CStr(intNbr) & " is multiple in column " & CStr(intCol  1) & ". " blnCheck = False End If Next intCol Next intNbr For intNbr = 1 To 9 For intRow = 9 To 17 intNbrCount = 0 For intCol = 2 To 10 If Cells(intRow, intCol).Value = intNbr Then intNbrCount = intNbrCount + 1 End If Next intCol If intNbrCount > 1 Then strMsg = strMsg & "Number " & CStr(intNbr) & " is multiple in row " & CStr(intRow  8) & ". " blnCheck = False End If Next intRow Next intNbr For intNbr = 1 To 9 intSqr = 0
For intRow = 9 To 17 Step 3 For intCol = 2 To 10 Step 3 intSqr = intSqr + 1 intNbrCount = 0
For intSqrCol = intCol To intCol + 2 For intSqrRow = intRow To intRow + 2 If Cells(intSqrRow, intSqrCol).Value = intNbr Then intNbrCount = intNbrCount + 1 End If Next intSqrRow Next intSqrCol
If intNbrCount > 1 Then strMsg = strMsg & "Number " & CStr(intNbr) & " is multiple in square " & CStr(intSqr) & ". " blnCheck = False End If
Next intCol Next intRow Next intNbr If blnCheck Then 'Copy Values from Sudoku to Solver For intCol = 2 To 10 For intRow = 9 To 17 If Len(Cells(intRow, intCol).Value) = 1 Then Cells(intRow, intCol + 10).Value = Cells(intRow, intCol).Value End If Next intRow Next intCol
'Update Solver to Solved Values For intRow = 9 To 17 For intCol = 12 To 20 strSlvOld = Cells(intRow, intCol).Value strSlvNew = "" If Len(strSlvOld) > 1 Then
For intStr = 1 To Len(strSlvOld) blnSlvFound = False strSlv = Mid(strSlvOld, intStr, 1) For intSlvRow = 9 To 17 If Cells(intSlvRow, intCol).Value = strSlv Then blnSlvFound = True End If Next intSlvRow For intSlvCol = 12 To 20 If Cells(intRow, intSlvCol).Value = strSlv Then blnSlvFound = True End If Next intSlvCol intSqrSlvRow = intRow intSqrSlvCol = intCol If intSqrSlvRow = 10 Or intSqrSlvRow = 13 Or intSqrSlvRow = 16 Then intSqrSlvRow = intSqrSlvRow  1 End If If intSqrSlvRow = 11 Or intSqrSlvRow = 14 Or intSqrSlvRow = 17 Then intSqrSlvRow = intSqrSlvRow  2 End If If intSqrSlvCol = 13 Or intSqrSlvCol = 16 Or intSqrSlvCol = 19 Then intSqrSlvCol = intSqrSlvCol  1 End If If intSqrSlvCol = 14 Or intSqrSlvCol = 17 Or intSqrSlvCol = 20 Then intSqrSlvCol = intSqrSlvCol  2 End If For intSlvRow = intSqrSlvRow To intSqrSlvRow + 2 For intSlvCol = intSqrSlvCol To intSqrSlvCol + 2 If Cells(intSlvRow, intSlvCol).Value = strSlv Then blnSlvFound = True End If Next intSlvCol Next intSlvRow
If blnSlvFound = False Then strSlvNew = strSlvNew & strSlv End If Next intStr Cells(intRow, intCol).Value = strSlvNew End If Next intCol Next intRow
'Update Solver to Single Existing Values For intRow = 9 To 17 For intCol = 12 To 20 strSlvOld = Cells(intRow, intCol).Value If Len(strSlvOld) > 1 Then blnSlvFound = False
For intStr = 1 To Len(strSlvOld) intRowSlvFound = 0 intColSlvFound = 0 intSqrSlvFound = 0 strSlv = Mid(strSlvOld, intStr, 1) For intSlvRow = 9 To 17 If InStr(Cells(intSlvRow, intCol).Value, strSlv) > 0 Then intColSlvFound = intColSlvFound + 1 End If Next intSlvRow For intSlvCol = 12 To 20 If InStr(Cells(intRow, intSlvCol).Value, strSlv) > 0 Then intRowSlvFound = intRowSlvFound + 1 End If Next intSlvCol intSqrSlvRow = intRow intSqrSlvCol = intCol If intSqrSlvRow = 10 Or intSqrSlvRow = 13 Or intSqrSlvRow = 16 Then intSqrSlvRow = intSqrSlvRow  1 End If If intSqrSlvRow = 11 Or intSqrSlvRow = 14 Or intSqrSlvRow = 17 Then intSqrSlvRow = intSqrSlvRow  2 End If If intSqrSlvCol = 13 Or intSqrSlvCol = 16 Or intSqrSlvCol = 19 Then intSqrSlvCol = intSqrSlvCol  1 End If If intSqrSlvCol = 14 Or intSqrSlvCol = 17 Or intSqrSlvCol = 20 Then intSqrSlvCol = intSqrSlvCol  2 End If For intSlvRow = intSqrSlvRow To intSqrSlvRow + 2 For intSlvCol = intSqrSlvCol To intSqrSlvCol + 2 If InStr(Cells(intSlvRow, intSlvCol).Value, strSlv) > 0 Then intSqrSlvFound = intSqrSlvFound + 1 End If Next intSlvCol Next intSlvRow
If (intColSlvFound = 1 Or intRowSlvFound = 1 Or intSqrSlvFound = 1) And blnSlvFound = False Then Cells(intRow, intCol).Value = strSlv blnSlvFound = True End If Next intStr End If Next intCol Next intRow
'Copy Values from Solver to Sudoku For intCol = 12 To 20 For intRow = 9 To 17 If Len(Cells(intRow, intCol).Value) = 1 Then Cells(intRow, intCol  10).Value = Cells(intRow, intCol).Value End If Next intRow Next intCol intRound = intRound + 1 Cells(20, 13).Value = intRound End If Cells(21, 13).Value = strMsg Application.ScreenUpdating = True
End Sub
Sub SaveSudoku() Dim intRow As Integer Dim intCol As Integer
Application.ScreenUpdating = False For intCol = 2 To 10 For intRow = 9 To 17 Cells(intRow + 30, intCol).Value = Cells(intRow, intCol).Value Next intRow Next intCol
Application.ScreenUpdating = True
End Sub
Sub RestoreSudoku() Dim intRow As Integer Dim intCol As Integer Application.ScreenUpdating = False For intCol = 2 To 10 For intRow = 9 To 17 Cells(intRow, intCol).Value = Cells(intRow + 30, intCol).Value Cells(intRow, intCol).Font.Color = RGB(0, 0, 0) Next intRow Next intCol
Cells(20, 13).Value = 0
Application.ScreenUpdating = True
End Sub
Sub RandomValue() Dim intRow As Integer Dim intCol As Integer Dim intUsedCells As Integer Dim strMsg As String Dim blnFoundCell As Boolean Dim intValue As Integer Application.ScreenUpdating = False intUsedCells = 0 strMsg = ""
For intCol = 2 To 10 For intRow = 9 To 17 If Not IsNull(Cells(intRow, intCol).Value) And Cells(intRow, intCol).Value <> "" Then intUsedCells = intUsedCells + 1 End If Next intRow Next intCol If intUsedCells < 81 Then blnFoundCell = False While blnFoundCell = False intRow = 9 + Int(Rnd(1) * 9) intCol = 2 + Int(Rnd(1) * 9) intValue = 1 + Int(Rnd(1) * 9) If IsNull(Cells(intRow, intCol).Value) Or Cells(intRow, intCol).Value = "" Then Cells(intRow, intCol).Value = intValue Cells(intRow, intCol).Select blnFoundCell = True End If Wend Else strMsg = strMsg & "All Sudoku cells are used. " End If
Cells(21, 13).Value = strMsg
Application.ScreenUpdating = True
End Sub
Sub ClearSudoku() Dim intRow As Integer Dim intCol As Integer
Columns("B:J").ColumnWidth = 4 Columns("L:T").ColumnWidth = 10 For intCol = 2 To 10 For intRow = 9 To 17 Cells(intRow, intCol).Value = "" Cells(intRow, intCol).Font.Color = RGB(0, 0, 0) Next intRow Next intCol For intCol = 12 To 20 For intRow = 9 To 17 Cells(intRow, intCol).Value = "123456789" Next intRow Next intCol Cells(20, 13).Value = 0 Cells(21, 13).Value = ""
End Sub


Christopher Dearlove
United Kingdom Chelmsford Essex
SoRCon 11 2325 Feb 2018 Basildon UK http://www.sorcon.co.uk

If you want a different approach, using formulae rather than macros (thus free of any possible macro malware) there's one on my website, start at www.mnemosyne.demon.co.uk. Bad news: doesn't solve everything. Good news: it's intended not to solve the whole thing but provide you with hints or answers about what's next, at different levels of solver sophistication. (The can't solve everything is that I never worked out how to do another level in formulae.)


Andy Andersen
United States Michigan

If you can work that out when you're sick, I hate to think of how productive you are when you're well.


Erik Henry
United States Houston Texas
Science without religion is lame, religion without science is blind—Einstein

Very cool!
Have you tried the Skyscrapers or Sumscrapers puzzles? They're similarstill fitting one of each digit in each row and columnbut use a different mechanism than the 3x3 square to constrain the problem. They provide the same type of enjoymenthunting for that one move that you have enough information to deduce, which then opens up another move, etc.but I often prefer them.
There are good examples of both (and many other types of logic puzzles) in the app "100 Logic Games" by Andrea Sabbatini. I know it's available for iOS...not sure about other platforms.


Some dude
Netherlands Groningen There dismay took them, for at the gate was a guard of whom no tidings had yet gone forth.
Swiftly the wolf grew, until he could creep into no den, but lay huge and hungry before the feet of Morgoth. There the fire and anguish of hell entered into him, and he became filled with a devouring spirit, tormented, terrible, and strong.
Then swiftly all his inwards were filled with a flame of anguish, and the Silmaril seared his accursed flesh. Howling he led before them, and the walls of the valley of the Gate echoes with the clamour of his torment.

I have written a few Sudoku solvers over the years. My first was also in Excel with VBA. It must have been about 15 years ago or so.
It is one of the most fun programming problems. The best method I found for solving these puzzles is an algorithm called 'Dancing Links'. It solves hundreds of puzzles per second. It can also be used to solve other kind of puzzles. I think it's really neat. It's a little more complicated than just looping over all the cells, though.


Jens Hoppe
Denmark Frederiksberg
The current moderation is unfair and onesided...
... So I am not supporting BGG in 2019

Reminds me of the Oracle SQL statement I once saw, which also solves Sudokus.


Chris Long
United States State College Pennsylvania
Fly Eagles Fly!
The Cthulhu player, not the Football player.

I got really good at Sudoku for a while there, doing one puzzle a day at least. After doing nothing but expert puzzles for a while, it was difficult to switch back to the "hard" level because the tricks they used were all different.



