Here is my code for solving SDOKU. It uses a recursive algorithm to get the
solution by trying every combination. You could speed up the code by adding
inteligence. the code works within a couple of minutes for a standard 9 x 9
puzzle.
Dim Completed As Boolean
Dim RecursiveCount As Integer
Sub Sudoku()
Const SudukoSheet As String = "Sudoku"
Dim Board(9, 9) As Integer
Dim BoxColumn As Integer
Dim BoxRow As Integer
Dim CheckColumn As Integer
Dim CheckRow As Integer
Dim Column As Integer
Dim ErrorColumn As Integer
Dim ErrorRow As Integer
Dim ErrorString As String
Dim FirstColumn As Integer
Dim FirstRow As Integer
Dim Number As Integer
Dim NumerFound As Boolean
Dim Row As Integer
Completed = False
RecursiveCount = 1
'check for errors
For Row = 1 To 9
For Column = 1 To 9
If (Worksheets(SudukoSheet).Cells(Row, Column).Value <> "") Then
If (Worksheets(SudukoSheet).Cells(Row, Column).Value < "1") Or _
(Worksheets(SudukoSheet).Cells(Row, Column).Value > "9") Or _
(Len(Worksheets(SudukoSheet).Cells(Row, Column).Value) <> 1) Then
ErrorString = "Incorrect Value in cell " + Chr(Asc("A") + Column
- 1) + CStr(Row)
MsgBox (ErrorString)
Exit Sub
End If
End If
Next Column
Next Row
For Row = 1 To 9
For Column = 1 To 9
If Worksheets(SudukoSheet).Cells(Row, Column).Value = "" Then
Board(Row, Column) = 0
Else
Board(Row, Column) = Worksheets(SudukoSheet).Cells(Row, Column).Value
Worksheets(SudukoSheet).Cells(Row, Column).Font.Bold = True
Worksheets(SudukoSheet).Cells(Row, Column).Font.ColorIndex = 1
End If
Next Column
Next Row
'check for errors
NumberFound = False
For Row = 1 To 9
For Column = 1 To 9
If Board(Row, Column) <> 0 Then
Number = Board(Row, Column)
'check column
For CheckRow = 1 To 9
If (CheckRow <> Row) And (Board(CheckRow, Column) = Number) Then
NumberFound = True
ErrorColumn = Column
ErrorRow = CheckRow
Exit For
End If
Next CheckRow
'check row
If NumberFound = False Then
For CheckColumn = 1 To 9
If (CheckColumn <> Column) And (Board(Row, CheckColumn) =
Number) Then
NumberFound = True
ErrorColumn = CheckColumn
ErrorRow = Row
Exit For
End If
Next CheckColumn
End If
'check box
If NumberFound = False Then
BoxColumn = (3 * ((Column - 1) \ 3)) + 1
BoxRow = (3 * ((Row - 1) \ 3)) + 1
For CheckRow = BoxRow To (BoxRow + 2)
For CheckColumn = BoxColumn To (BoxColumn + 2)
If (CheckRow <> Row) And (CheckColumn <> Column) And _
(Board(CheckRow, CheckColumn) = Number) Then
NumberFound = True
ErrorColumn = CheckColumn
ErrorRow = CheckRow
Exit For
End If
Next CheckColumn
If NumberFound = True Then
Exit For
End If
Next CheckRow
End If
End If
If NumberFound = True Then
Exit For
End If
Next Column
If NumberFound = True Then
Exit For
End If
Next Row
If NumberFound = False Then
FirstColumn = 0
FirstRow = 1
Call SolveSudoku(Board, FirstRow, FirstColumn)
Else
'error
ErrorString = "Duplicate Value in cell " + Chr(Asc("A") + Column - 1) +
CStr(Row)
ErrorString = ErrorString + " and cell " + Chr(Asc("A") + ErrorColumn -
1) + CStr(ErrorRow)
MsgBox (ErrorString)
End If
If Completed = False Then
Response = MsgBox("There is no solution to this puzzle. Press OK to
Continue:")
End If
End Sub
Sub SolveSudoku(Board, OldRow As Integer, OldColumn As Integer)
Const SudukoSheet As String = "Sudoku"
Dim NewBoard(9, 9) As Integer
Dim BoxColumn As Integer
Dim BoxRow As Integer
Dim CheckColumn As Integer
Dim CheckRow As Integer
Dim Column As Integer
Dim FirstColumn As Integer
Dim FirstLoop As Boolean
Dim Found As Boolean
Dim Number As Integer
Dim NumerFound As Boolean
Dim Row As Integer
For Row = 1 To 9
For Column = 1 To 9
NewBoard(Row, Column) = Board(Row, Column)
Next Column
Next Row
'increment row and column to next box
If OldColumn = 9 Then
CheckRow = OldRow + 1
CheckColumn = 1
Else
CheckColumn = OldColumn + 1
CheckRow = OldRow
End If
'find empty cell
Found = False
FirstLoop = True
For Row = CheckRow To 9
If FirstLoop = True Then
FirstLoop = False
FirstColumn = CheckColumn
Else
FirstColumn = 1
End If
For Column = FirstColumn To 9
If NewBoard(Row, Column) = 0 Then
Found = True
Exit For
End If
Next Column
If Found = True Then
Exit For
End If
Next Row
If Found = False Then
Completed = True
For Row = 1 To 9
For Column = 1 To 9
Worksheets(SudukoSheet).Cells(Row, Column).Select
If Selection.Value = "" Then
Selection.Value = NewBoard(Row, Column)
Selection.Font.ColorIndex = 3
End If
With Selection.Font
.Name = "Arial"
.Size = 24
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.ColumnWidth = 8.3
End With
Next Column
Next Row
Else
For Number = 1 To 9
NumberFound = False
'check column
For CheckRow = 1 To 9
If NewBoard(CheckRow, Column) = Number Then
NumberFound = True
Exit For
End If
Next CheckRow
'check row
If NumberFound = False Then
For CheckColumn = 1 To 9
If NewBoard(Row, CheckColumn) = Number Then
NumberFound = True
Exit For
End If
Next CheckColumn
End If
'check box
If NumberFound = False Then
BoxColumn = (3 * ((Column - 1) \ 3)) + 1
BoxRow = (3 * ((Row - 1) \ 3)) + 1
For CheckRow = BoxRow To (BoxRow + 2)
For CheckColumn = BoxColumn To (BoxColumn + 2)
If NewBoard(CheckRow, CheckColumn) = Number Then
NumberFound = True
Exit For
End If
Next CheckColumn
If NumberFound = True Then
Exit For
End If
Next CheckRow
End If
If NumberFound = False Then
NewBoard(Row, Column) = Number
Call SolveSudoku(NewBoard, Row, Column)
End If
If Completed = True Then
Exit For
End If
Next Number
End If
End Sub
Sub Clear()
Const SudukoSheet As String = "Sudoku"
Dim Column As Integer
Dim Row As Integer
For Row = 1 To 9
For Column = 1 To 9
Worksheets(SudukoSheet).Cells(Row, Column).Value = ""
Worksheets(SudukoSheet).Cells(Row, Column).Font.ColorIndex = 1
Next Column
Next Row
End Sub
