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
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...
) , set the Scale bubble size to e.g. 15 (Area of bubbles), then click on Fill & Line icon (
), select Fill>Automatic and mark Vary colors by point.
) and select those elements which you want to be displayed in the chart (titles, axes, gridlines, data labels, error bars, legend, trendline). Make any changes you want to those elements.
) and select your favorite style and color scheme for your chart.