If you are Sudoku solver you probably spent hours and hours trying to solve the puzzles. I'd like to show here that in Excel, with help of VBA macros, you can do it usually in seconds.

Create your own private Sudoku solver tool, which will not only solve the puzzle but also create your own, at different levels of difficulty. I'll guide you through all the steps.

__In the first step__, you'll need to design your worksheet structure/view. Start with Sudoku 9 x 9 cells square. Use any colors you like to create a pleasant display of the matrix. I've used RowHeight of 33 and ColumnWidth of 6 to make cells look like squares.

Here is my design shown in two stages: with blank fields (*before creating a puzzle*) and with filled fields (*after solving a puzzle*).

After formatting of the layout as presented in the example above, comes __the second step__ - filling designated cells with formulas. Enter them as follows:

- Make sure that the range of cells
**P1:X9**is left blank. - Hide Columns
**L:AJ**and**AN:DP**.

__Step three__. Now you need to insert three command buttons: **Create**, **Solve**, and **Clear**, as you see in the example above.

In **Developer** Menu **Controls** turn on the **Design Mode** and click on **Insert** to insert **Command Button** from **ActiveX Controls**. Size the button as needed.

Right-click on the button and select **Properties**. Change Caption Name to "Create". Right-click again on the button and select **View Code**. In the Sheet1 code page enter the following code:

**Private Sub CommandButton1_Click()**

'CommandButton "Create"

Range("sudoku").Font.Color = vbBlack

RrLogic = 1

MainCod

End Sub

Return to your worksheet and create next two buttons the same way, but name them "**Solve**" and "**Clear**".

For "**Solve**" button enter the following code:

**Private Sub CommandButton2_Click()**

'CommandButton "Solve"

'Dim CheckArray(9)

If Cells(1, 38) = 0 Then End ' Checks if the empty cells are 0(solved sudoku)

Range("sudoku").Font.Color = vbBlack

For x = 1 To 9 'checks if there are same numbers in row,column,box

For y = 1 To 9

rX = "a" & x & ":" & "i" & x ' Finds the coords of the range(row,column,box)

rY = Chr(y + 64) & "1" & ":" & Chr(y + 64) & "9"

xK = 1 + Int((x - 1) / 3) * 3

yK = 1 + Int((y - 1) / 3) * 3

rK = Chr(yK + 64) & xK & ":" & Chr(yK + 66) & xK + 2

r = rX & "," & rY & "," & rK

Set MyRange = Range(r)

If Cells(x, y) = "" Then GoTo nextxy

temp = Cells(x, y)

Cells(x, y) = ""

For Each c In MyRange.Cells

If c.Value = temp Then

Cells(x, y) = temp

c.Font.Color = vbRed

Cells(x, y).Font.Color = vbRed

Message = MsgBox("Exits Sudoku", vbOKOnly)

End

End If

Next

Cells(x, y) = temp

nextxy:

Next y, x

For x = 1 To 9 'Input data in an array

For y = 1 To 9

InputData(x, y) = Cells(x, y)

Next y, x

RrLogic = 2 ' If RrLogic =1 then Create Sudoku or If RrLogic =2 then Solve Sudoku

MainCod

End Sub

For "**Clear**" button enter this code:

**Private Sub CommandButton3_Click()**

'CommandButton "Clear"

Range("sudoku").Font.Color = vbBlack

For x = 1 To 9

For y = 1 To 9

Cells(x, y) = ""

Next y, x

End Sub

__In step four__, enter shortcut **ALT+F11** to open VBE page and click on the **View** in menu to select **Project Explorer**. If there is no Module available within your VBA Project, then insert one by clicking on the **Insert **in the menu. Double-click on the **Module** and and paste there the following Sub procedures:

**Public InputData(9, 9), SpecialAr(), XCoords(), YCoords(), RrCount, RrLogic, CurNum As Integer**

Public IsZero, AnyChanges As Boolean

Public x, y, MidNum, TempVar

Public MyRange As Range

Public TheSame As String**Public Sub MainCod()**

Randomize Timer

wrongRep = 0: Xronos = Timer

1 IsZero = False

If RrLogic = 1 Then CreateSudoku Else SolveSudoku

wrongRep = wrongRep + 1 '*Count of tries to solve sudoku*

Do

CheckArea:

IsZero = False '*Becomes True when "123456789" is zero*

If Cells(2, 38) = 1 Then GoTo 3 'Check if unique num in 2nd string array (in row, col or box)

ReDim SpecialAr(9), XCoords(4), YCoords(4)

AnyChanges = False '*True if any changes made after any check*

For x = 1 To 9 'Row check

For y = 1 To 9

For k = 1 To Len(Cells(x, y + 15))

If Cells(x, y + 15) = "0000000000" Then Exit For

MidNum = Mid(Cells(x, y + 15), k, 1)

SpecialAr(MidNum) = SpecialAr(MidNum) + 1 '*Counts occurrence of a number in row*

Next k

Next y

For l = 1 To 9

If SpecialAr(l) = 1 Then

For y = 1 To 9 '*Find cell with the unique number*

For k = 1 To Len(Cells(x, y + 15)) '*Loop every char in the string*

MidNum = Mid(Cells(x, y + 15), k, 1)

If Val(MidNum) = l Then

Cells(x, y) = l '*The unique number in the 1st table*

Cells(x, y + 15) = "0000000000" '*Set the string in the array for every completed cell in the 1st table*

CurNum = Cells(x, y) '*Current cell investigated*

RepairStr '*Calls the sub fixing the string table after cell is completed in 1st table*

If IsZero = True Then GoTo 1 '*Go back to the beginning if cannot go any further*

GoTo CheckArea '*Make all the check if any change has been made*

End If

Next k, y

Else

End If

Next l

ReDim SpecialAr(9)

Next x

'*Column check*

For y = 1 To 9 '*The same as above with exchanging the x and y coordinates*

For x = 1 To 9

For k = 1 To Len(Cells(x, y + 15))

If Cells(x, y + 15) = "0000000000" Then Exit For

MidNum = Mid(Cells(x, y + 15), k, 1)

SpecialAr(MidNum) = SpecialAr(MidNum) + 1

Next k

Next x

For l = 1 To 9

If SpecialAr(l) = 1 Then

For x = 1 To 9

For k = 1 To Len(Cells(x, y + 15))

MidNum = Mid(Cells(x, y + 15), k, 1)

If Val(MidNum) = l Then

Cells(x, y) = l: Cells(x, y + 15) = "0000000000"

CurNum = Cells(x, y)

RepairStr

If IsZero = True Then GoTo 1

GoTo CheckArea

End If

Next k, x

Else

End If

Next l

ReDim SpecialAr(9)

Next y

x = 0: y = 0

'Box check

For i = 1 To 6 Step 3 '*The same as above but using the x and y coordinates of the box*

For j = 1 To 6 Step 3

For n = 0 To 2

For g = 0 To 2

x = i + n: y = j + g

For k = 1 To Len(Cells(x, y + 15))

If Cells(x, y + 15) = "0000000000" Then Exit For

MidNum = Mid(Cells(x, y + 15), k, 1)

SpecialAr(MidNum) = SpecialAr(MidNum) + 1

Next k

Next g, n

For l = 1 To 9

If SpecialAr(l) = 1 Then

For n = 0 To 2

For g = 0 To 2

x = i + n: y = j + g

For k = 1 To Len(Cells(x, y + 15))

MidNum = Mid(Cells(x, y + 15), k, 1)

If Val(MidNum) = l Then

Cells(x, y) = l: Cells(x, y + 15) = "0000000000"

CurNum = Cells(x, y)

RepairStr

If IsZero = True Then GoTo 1

GoTo CheckArea

End If

Next k

Next g, n

Else

End If

Next l

ReDim SpecialAr(9)Next j, i

'*Check if there is a couple a triad or tetrad in the same row, column or box*

If RrLogic = 1 Then GoTo 3

For x = 1 To 9 'row check

For y = 1 To 8

For k = y + 1 To 9

If Cells(x, y + 15) = Cells(x, k + 15) And Len(Cells(x, y + 15)) < 5 Then

YCoords(1) = y: TheSame = Cells(x, y + 15)

For i = 2 To 4 '*Give the Y coords of the same cells to the YCoords array*

If YCoords(i) = 0 Then YCoords(i) = k: Exit For

Next i

Else

End If

Next k

'*If there are same cells, call the CheckSameY sub & keep the current row in the TempVar variable*

If YCoords(1) <> 0 Then TempVar = x: CheckSameY: Exit For

Next y

If IsZero = True Then GoTo 1

If AnyChanges = True Then GoTo CheckArea

Next x

IsZero = False

For y = 1 To 9 '*Column check*

For x = 1 To 8

For k = x + 1 To 9

If Cells(x, y + 15) = Cells(k, y + 15) And Len(Cells(x, y + 15)) < 5 Then

XCoords(1) = x: TheSame = Cells(x, y + 15)

For i = 2 To 4 '*Give the Y coords of the sam cells to the YCoords array*

If XCoords(i) = 0 Then XCoords(i) = k: Exit For

Next i

Else

End If

Next k

'*If there are same cells then call the CheckSameY sub & keep the current row in the TempVar variable*

If XCoords(1) <> 0 Then TempVar = y: RemRepeats: Exit For

Next x

If IsZero = True Then GoTo 1

If AnyChanges = True Then GoTo CheckArea

Next y

'*Take the returned value of match function which finds the string with the minimum legth*

3 synt = Cells(3, 38)

'*Convert the coordinates of the 1x81 array to the 9x9 array*

x = Int((synt - 1) / 9) + 1

y = synt - (Int((synt - 1) / 9) * 9)

PithNum = Cells(x, y + 15) '*Give to a var the string with possible number for the cell*

'*Return a random number from 1 to the length of the string*

RndNum = Int(Rnd * Len(Cells(x, y + 15))) + 1

'*Give to a var the corresponding number*

CurNum = Mid(PithNum, RndNum, 1)

Cells(x, y) = CurNum

Cells(x, y + 15) = "0000000000"

RepairStr

If IsZero = True Then GoTo 1

Loop Until Cells(1, 38) = 0

Cells(4, 38) = wrongRep

Cells(5, 38) = Timer - Xronos

If RrLogic = 1 Then DelCells

End Sub

**Public Sub CreateSudoku()**

'*Prepare the tables to start creating a new sudoku*

For x = 1 To 9

For y = 1 To 9

Cells(x, y + 15) = "123456789"

Cells(x, y) = ""

Next y, x

End Sub

**Public Sub SolveSudoku()**

'*Solve a sudoku given by the user or created from the program*

For x = 1 To 9 '*Gives all the combinations to the string table*

For y = 1 To 9

Cells(x, y + 15) = "123456789"

Next y, x

For x = 1 To 9 '*Insert all the given data from the array into the 1st table*

For y = 1 To 9

If InputData(x, y) = 0 Then Cells(x, y) = "": GoTo 2

Cells(x, y) = InputData(x, y)

Cells(x, y).Font.Color = vbRed '*Cells with data become red*

CurNum = Cells(x, y) '*For any given num fix the corresponding string*

Cells(x, y + 15) = "0000000000"

RepairStr

If IsZero = True Then Message = MsgBox("Not Possible", vbOKOnly): End

2 Next y, x

End Sub**Public Sub RepairStr()**

rX = "p" & x & ":" & "x" & x '*Make the range in 2nd table, for every cell of 1st table, which contains row, column and box*

rY = Chr(y + 79) & "1" & ":" & Chr(y + 79) & "9"

xK = 1 + Int((x - 1) / 3) * 3

yK = 1 + Int((y - 1) / 3) * 3

rK = Chr(yK + 79) & xK & ":" & Chr(yK + 81) & xK + 2

r = rX & "," & rY & "," & rK

Set MyRange = Range(r)

For Each c In MyRange.Cells '*Subtract the current number from any string of the range*

For j = 1 To Len(c.Value)

If Mid(c.Value, j, 1) <> CurNum Then tempXY$ = tempXY$ + Mid(c.Value, j, 1)

Next

If tempXY$ = "" Then IsZero = True '*Check if the string with possible num is nothing that means that the sudoku cannot be solved*

c.Value = tempXY$

tempXY$ = ""

Next

End Sub

**Public Sub CheckSameY()**

*Subtract diads, triads and tetrads from the string in the same row*

AnyChanges = False

x = TempVar: TempVar = "" '

*Variable containing the current x coordinate*

metritis = 0

If YCoords(Len(TheSame)) = 0 Then ReDim YCoords(4): Exit Sub

For k = 1 To 9

If Cells(x, k + 15) = "0000000000" Then metritis = metritis + 1

Next k

'*Check if there are no more empty cells in the 1st table except the diads, triads or tetrads*

If Len(TheSame) + metritis = 9 Then ReDim YCoords(4): Exit Sub

For y = 1 To 9

For i = 1 To Len(TheSame)

If y = YCoords(i) Then GoTo 1 '*Prevent the program from subtracting the numbers from the cells which contains the diads, triads or tetrads*

Next i

For i = 1 To Len(TheSame)

For k = 1 To Len(Cells(x, y + 15))

MidNum = Mid(Cells(x, y + 15), k, 1)

If MidNum <> Mid(TheSame, i, 1) Then TempVar = TempVar + MidNum

If MidNum = Mid(TheSame, i, 1) Then AnyChanges = True

Next k

If TempVar = "" Then IsZero = True

Cells(x, y + 15) = TempVar

TempVar = ""

Next i

1 Next y

ReDim YCoords(4)

End Sub

Public Sub RemRepeats() '*Subtract diads, triads and tetrads from the string in the same row*

AnyChanges = False

y = TempVar: TempVar = "" '*Variable containing the current y coordinate*

metritis = 0

If XCoords(Len(TheSame)) = 0 Then ReDim XCoords(4): Exit Sub

For k = 1 To 9

If Cells(k, y + 15) = "0000000000" Then metritis = metritis + 1

Next k

'*Check if there are no more empty cells in the s1 tables except the diads, triads or tetrads*

If Len(TheSame) + metritis = 9 Then ReDim XCoords(4): Exit Sub

For x = 1 To 9

'*Prevent the program from subtracting the numbers from the cells which contains the diads, triads or tetrads*

For i = 1 To Len(TheSame)

If x = XCoords(i) Then GoTo 1

Next i

For i = 1 To Len(TheSame)

For k = 1 To Len(Cells(x, y + 15))

MidNum = Mid(Cells(x, y + 15), k, 1)

If MidNum <> Mid(TheSame, i, 1) Then TempVar = TempVar + MidNum

If MidNum = Mid(TheSame, i, 1) Then AnyChanges = True

Next k

If TempVar = "" Then IsZero = True

Cells(x, y + 15) = TempVar

TempVar = ""

Next i

1 Next x

ReDim XCoords(4)

End Sub**Public Sub DelCells()**

'*Delete cells randomly(get ready to play)*

RrCount = 0

10 Do

x = Int((Rnd * 9) + 1)

y = Int((Rnd * 9) + 1)

'Stop

If Cells(x, y) <> "" Then

Cells(x, y) = ""

Else

GoTo 10

End If

RrCount = RrCount + 1

Loop Until RrCount = Cells(6, 38)

End Sub

Go back to your worksheet. Turn off the **Design Mode** and check if everything was entered correctly and works as intended. Finish any formatting and save your workbook as Macro-Enabled one.

Happy Sudoku-ing...