Recommend
7 
 Thumb up
 Hide
7 Posts

BoardGameGeek» Forums » Everything Else » Chit Chat

Subject: Sudoku Solver in MS-Excel rss

Your Tags: Add tags
Popular Tags: [View All]
Harmonica
Netherlands
Tilburg
Noord-Brabant
flag msg tools
badge
Keep your lovin' brother happy!
Avatar
mbmbmbmbmb
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 MS-Excel". Below is the result. Follow the instructions below and have fun. Maybe you'll learn something!

Disclaimer
* The VBA-code is free of virusses, including my flu-virus, 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 Solver-grid 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 B9-J17: 16pt, Bold with borders
* Cells B39-J47: 16pt, Bold with borders
* Cells L9-T17: 10pt, Bold with borders
* Columns B-J: Width=4
* Columns L-T: Width=10
* Copy-Paste the VBA-Code 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
5 
 Thumb up
0.02
 tip
 Hide
  • [+] Dice rolls
Christopher Dearlove
United Kingdom
Chelmsford
Essex
flag msg tools
SoRCon 11 23-25 Feb 2018 Basildon UK http://www.sorcon.co.uk
badge
Avatar
mbmbmbmbmb
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.)
2 
 Thumb up
 tip
 Hide
  • [+] Dice rolls
Andy Andersen
United States
Michigan
flag msg tools
badge
Avatar
mbmbmbmbmb
If you can work that out when you're sick, I hate to think of how productive you are when you're well. shake
2 
 Thumb up
0.25
 tip
 Hide
  • [+] Dice rolls
Erik Henry
United States
Houston
Texas
flag msg tools
badge
Science without religion is lame, religion without science is blind—Einstein
Avatar
mbmbmbmbmb
Very cool!

Have you tried the Skyscrapers or Sumscrapers puzzles? They're similar--still fitting one of each digit in each row and column--but use a different mechanism than the 3x3 square to constrain the problem. They provide the same type of enjoyment--hunting 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.
1 
 Thumb up
 tip
 Hide
  • [+] Dice rolls
Some dude
Netherlands
Groningen
There dismay took them, for at the gate was a guard of whom no tidings had yet gone forth.
flag msg tools
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.
badge
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.
Avatar
mbmbmbmbmb
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.
1 
 Thumb up
 tip
 Hide
  • [+] Dice rolls
Jens Hoppe
Denmark
Frederiksberg
flag msg tools
The current moderation is unfair and one-sided...
badge
... So I am not supporting BGG in 2019
Avatar
mbmbmbmbmb
Reminds me of the Oracle SQL statement I once saw, which also solves Sudokus.
1 
 Thumb up
 tip
 Hide
  • [+] Dice rolls
Chris Long
United States
State College
Pennsylvania
flag msg tools
Fly Eagles Fly!
badge
The Cthulhu player, not the Football player.
Avatar
mbmbmbmbmb
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.
 
 Thumb up
 tip
 Hide
  • [+] Dice rolls
Front Page | Welcome | Contact | Privacy Policy | Terms of Service | Advertise | Support BGG | Feeds RSS
Geekdo, BoardGameGeek, the Geekdo logo, and the BoardGameGeek logo are trademarks of BoardGameGeek, LLC.