Sudoku Solver

A professional tool to be able to solve complex sudoku games. The VBA program uses logic and guess functions to solve the game.

Explanation

Sudoku solver uses basic logic functions and by this approach eliminates possible numbers in certain positions. For complex games it also has a guess function and loops through different solutions until the correct one is found. This sudoku solver will solve all sudokus also the impossible ones or the ones where only one figure is to start with. When starting with a very low number of data the outcome can vary and the program will find different end solutions. In some cases the program tries an approach that fails then the program starts again and finally the right solution is found. The program can be optimized in speed if the visual effects is turned off before executing the program.

Code

Public Sub Sudoku_Solver_One()
'Start program to solve one step
Total = False
Call Sudoku_Solver(Total)
End Sub
Public Sub Sudoku_Solver_Total()
'Start program to solve complete
Total = True
Call Sudoku_Solver(Total)
End Sub

Public Sub Sudoku_Solver(Total)

Range("N3:V11").ClearContents
Range("N3:V11").Interior.ColorIndex = 0

'write_it controls if the program has written anything new to the matrix if not then the guess program is executed
write_it = False

'The array containing all data
Dim Sudoku_Solver(9, 9, 40)

Call ReadInData(Sudoku_Solver)
Call write_itData(Sudoku_Solver, write_it)
Call DetermineReady(Sudoku_Solver)

lups = 0
ER = False
While ER = False
    For Row = 1 To 9
        For Column = 1 To 9
            If Sudoku_Solver(Row, Column, 0) = tom Then
                write_it = False
                'Basic methods for solving Sudoku
                Call QuadrantCheck(Sudoku_Solver, Row, Column, write_it)
                Call RowCheck(Sudoku_Solver, Row, Column, write_it)
                Call ColumnCheck(Sudoku_Solver, Row, Column, write_it)
                Call QuadrantCheckIN(Sudoku_Solver, Row, Column, write_it)
                Call RowCheckIN(Sudoku_Solver, Row, Column, write_it)
                Call ColumnCheckIN(Sudoku_Solver, Row, Column, write_it)
                Call DetermineReady(Sudoku_Solver)
            End If
        Next
    Next

'?!?!

    ReStart = False
    'Searches for errors if the error is found during first run the program ends
    Call CheckError(Sudoku_Solver, ReStart, start)
    If ReStart = True Then
        write_it = True
        Erase Sudoku_Solver
        Call ReadInData(Sudoku_Solver)
        Range("N3:V11").ClearContents
        Call write_itData(Sudoku_Solver, write_it)
        StartAllOver = StartAllOver + 1
        If StartAllOver > 1000 Then
            End
        End If
        If lups = 0 Then
            End
        End If
  
    End If

    If write_it = False Then
        Call Guess(Sudoku_Solver, write_it, StartAllOver)
    End If

    Call DetermineReady(Sudoku_Solver)
    If Total = True Then
        Call write_itData(Sudoku_Solver, write_it)
    End If
    Call CheckReady(Sudoku_Solver, ER)
    lups = lups + 1
Wend

If Total = False Then
    Call WriteOne(Sudoku_Solver)
End If

End Sub

Public Sub ReadInData(Sudoku_Solver)

For Row = 1 To 9
    For Column = 1 To 9
        Sudoku_Solver(Row, Column, 11) = Range("c3").Offset(Row - 1, Column - 1).Value
        Sudoku_Solver(Row, Column, 0) = Range("c3").Offset(Row - 1, Column - 1).Value
        If Sudoku_Solver(Row, Column, 0) = tom Then
            For loops = 1 To 9
                Sudoku_Solver(Row, Column, loops) = 1
            Next
        Else
            For loops = 1 To 9
                Sudoku_Solver(Row, Column, loops) = 0
            Next
        End If

        If Column < 4 Then
            If Row < 4 Then
                Sudoku_Solver(Row, Column, 10) = 1
            End If
            If Row < 7 And Row > 3 Then
                Sudoku_Solver(Row, Column, 10) = 4
            End If
            If Row > 6 Then
                Sudoku_Solver(Row, Column, 10) = 7
            End If
        End If

        If Column < 7 And Column > 3 Then
            If Row < 4 Then
                Sudoku_Solver(Row, Column, 10) = 2
            End If
            If Row < 7 And Row > 3 Then
                Sudoku_Solver(Row, Column, 10) = 5
            End If
            If Row > 6 Then
                Sudoku_Solver(Row, Column, 10) = 8
            End If
        End If

        If Column > 6 Then
            If Row < 4 Then
                Sudoku_Solver(Row, Column, 10) = 3
            End If
            If Row < 7 And Row > 3 Then
                Sudoku_Solver(Row, Column, 10) = 6
            End If
            If Row > 6 Then
                Sudoku_Solver(Row, Column, 10) = 9
            End If
        End If
    Next
Next

End Sub



Public Sub write_itData(Sudoku_Solver, write_it)

For Row = 1 To 9
    For Column = 1 To 9
        If Range("n3").Offset(Row - 1, Column - 1).Value = tom Then
            If Sudoku_Solver(Row, Column, 0) <> tom Then
                Range("n3").Offset(Row - 1, Column - 1).Value = Sudoku_Solver(Row, Column, 0)
                write_it = True
            End If
        End If
    Next
Next

End Sub

Public Sub DetermineReady(Sudoku_Solver)

For Row = 1 To 9
    For Column = 1 To 9
        For värde = 1 To 9
            If Sudoku_Solver(Row, Column, värde) = 1 Then
                antal = antal + 1
                värdeTal = värde
            End If
        Next
        If antal = 1 Then
            Sudoku_Solver(Row, Column, värdeTal) = 0
            Sudoku_Solver(Row, Column, 0) = värdeTal
        End If
        antal = 0
    Next
Next

End Sub

'?!?!

Public Sub QuadrantCheck(Sudoku_Solver, Row, Column, write_it)

kvadrant = Sudoku_Solver(Row, Column, 10)

For RowT = 1 To 9
    For ColumnT = 1 To 9
        If Sudoku_Solver(RowT, ColumnT, 10) = kvadrant Then
            If Sudoku_Solver(RowT, ColumnT, 0) <> tom Then
                tal = Sudoku_Solver(RowT, ColumnT, 0)
            If Sudoku_Solver(Row, Column, tal) = 1 Then
                Sudoku_Solver(Row, Column, tal) = 0
                write_it = True
            End If
            End If
        End If
    Next
Next

End Sub


Public Sub RowCheck(Sudoku_Solver, Row, Column, write_it)

For ColumnT = 1 To 9
    If Sudoku_Solver(Row, ColumnT, 0) <> tom Then
        värdeTal = Sudoku_Solver(Row, ColumnT, 0)
        If Sudoku_Solver(Row, Column, värdeTal) = 1 Then
            Sudoku_Solver(Row, Column, värdeTal) = 0
            write_it = True
        End If
    End If
Next

End Sub

Public Sub ColumnCheck(Sudoku_Solver, Row, Column, write_it)

For RowT = 1 To 9
    If Sudoku_Solver(RowT, Column, 0) <> tom Then
        värdeTal = Sudoku_Solver(RowT, Column, 0)
        If Sudoku_Solver(Row, Column, värdeTal) = 1 Then
            Sudoku_Solver(Row, Column, värdeTal) = 0
            write_it = True
        End If
    End If
Next

End Sub



Public Sub QuadrantCheckIN(Sudoku_Solver, Row, Column, write_it)

kvadrant = Sudoku_Solver(Row, Column, 10)

For värde = 1 To 9
    unik = True
    If Sudoku_Solver(Row, Column, värde) = 1 Then
        For RowT = 1 To 9
            For ColumnT = 1 To 9
                If Sudoku_Solver(RowT, ColumnT, 10) = kvadrant Then
                    If Sudoku_Solver(RowT, ColumnT, 0) = värde Then unik = False
                    If Sudoku_Solver(RowT, ColumnT, värde) = 1 Then
                        If Row = RowT And Column = ColumnT Then
                        Else
                            unik = False
                        End If
                    End If
                End If
            Next
        Next

        If unik = True Then
            Sudoku_Solver(Row, Column, 0) = värde
            write_it = True
            For lups = 1 To 9
                Sudoku_Solver(Row, Column, lups) = 0
            Next
        End If
  End If
Next

End Sub

Public Sub RowCheckIN(Sudoku_Solver, Row, Column, write_it)

For värde = 1 To 9
    unik = True
    If Sudoku_Solver(Row, Column, värde) = 1 Then
        For ColumnT = 1 To 9
            If Sudoku_Solver(Row, ColumnT, 0) = värde Then
                unik = False
            End If
            If Sudoku_Solver(Row, ColumnT, värde) = 1 Then
                If ColumnT <> Column Then
                    unik = False
                End If
            End If
        Next
        If unik = True Then
            Sudoku_Solver(Row, Column, 0) = värde
            write_it = True
            For lups = 1 To 9
                Sudoku_Solver(Row, Column, lups) = 0
            Next
        End If
    End If
Next

End Sub

'?!?!

Public Sub ColumnCheckIN(Sudoku_Solver, Row, Column, write_it)

kvadrant = Sudoku_Solver(Row, Column, 10)

For värde = 1 To 9
    unik = True
    If Sudoku_Solver(Row, Column, värde) = 1 Then
        For RowT = 1 To 9
            If Sudoku_Solver(RowT, Column, 0) = värde Then
                unik = False
            End If
            If Sudoku_Solver(RowT, Column, värde) = 1 Then
                If RowT <> Row Then
                    unik = False
                End If
            End If
        Next
        If unik = True Then
            Sudoku_Solver(Row, Column, 0) = värde
            write_it = True
            For lups = 1 To 9
                Sudoku_Solver(Row, Column, lups) = 0
            Next
        End If
    End If
Next

End Sub

Public Sub Guess(Sudoku_Solver, write_it, StartAllOver)

'identify best guess place

SlutSumma = 10
For Row = 1 To 9
    For Column = 1 To 9
        If Sudoku_Solver(Row, Column, 0) = tom Then
            For lups = 1 To 9
                summa = summa + Sudoku_Solver(Row, Column, lups)
            Next
            If summa < SlutSumma Then
                SlutRow = Row
                SlutColumn = Column
                SlutSumma = summa
            End If
            summa = 0
        End If
    Next
Next

If SlutSumma <> 0 Then
    'Random number between 1 and 9
    hittat = False
    While hittat = False
        Randomize
        tal = Int((9 * Rnd) + 1)
        If Sudoku_Solver(SlutRow, SlutColumn, tal) = 1 Then
            hittat = True
            Sudoku_Solver(SlutRow, SlutColumn, 0) = tal
            For lups = 1 To 9
                Sudoku_Solver(SlutRow, SlutColumn, lups) = 0
                write_it = True
            Next
        End If
    Wend
Else
    Erase Sudoku_Solver
    write_it = True
    Range("N3:V11").ClearContents
    Call ReadInData(Sudoku_Solver)
    Call write_itData(Sudoku_Solver, write_it)
    StartAllOver = StartAllOver + 1
    If StartAllOver > 1000 Then
        End
    End If
End If

'?!?!

End Sub

Public Sub CheckError(Sudoku_Solver, ReStart, start)

Dim R(9)
Dim C(9)

For Value = 1 To 9
    For Row = 1 To 9
        Erase R
        For Column = 1 To 9
            If Sudoku_Solver(Row, Column, 0) <> 0 Then
                R(Sudoku_Solver(Row, Column, 0)) = R(Sudoku_Solver(Row, Column, 0)) + 1
                If R(Sudoku_Solver(Row, Column, 0)) > 1 Then ReStart = True
            End If
        Next
    Next
    For Column2 = 1 To 9
        Erase C
        For Row2 = 1 To 9
            If Sudoku_Solver(Row2, Column2, 0) <> 0 Then
                C(Sudoku_Solver(Row2, Column2, 0)) = C(Sudoku_Solver(Row2, Column2, 0)) + 1
                If C(Sudoku_Solver(Row2, Column2, 0)) > 1 Then ReStart = True
            End If
        Next
    Next
Next

End Sub



Public Sub CheckReady(Sudoku_Solver, ER)

For Row = 1 To 9
    For Column = 1 To 9
        Summan = Summan + Sudoku_Solver(Row, Column, 0)
        If Sudoku_Solver(Row, Column, 0) <> tom Then
            Summan2 = Summan2 + 1
        End If
    Next
Next

If Summan = 405 And Summan2 = 81 Then
    ER = True
End If

End Sub

Public Sub WriteOne(Sudoku_Solver)

OneRandom = False
While OneRandom = False
    Randomize
    Row = Int((9 * Rnd) + 1)
    Column = Int((9 * Rnd) + 1)
    If Sudoku_Solver(Row, Column, 11) = tom Then
        Range("n3").Offset(Row - 1, Column - 1).Value = Sudoku_Solver(Row, Column, 0)
        Range("n3").Offset(Row - 1, Column - 1).Interior.ColorIndex = 4
    OneRandom = True
    End If
Wend

End Sub