Sudoku VBA Project

[Dim Me as xlNoob]

Hello everyone,

I've used this forum a lot to poke around and get tip and tricks on things here and there. I consider myself to have a good grasp of the the simpler aspects of VBA in excel, but still have so much to learn. I often set myself little projects to try and revise and expand my skills. So down to it I guess.

I don't have a specific question with this really, I'm more throwing my code out here for review and to see how others would do it differently. I've written a subroutine which generates a completed sudoku puzzle. It works over and over, but it can sometimes take quite some time (ok like 10 seconds or so). I just wonder if there is a more efficient way this could be done.

I've tried to comment my code to make it apparent what I'm doing and why. If you don't get my train of thought along the way please ask me.

Later I'll implement a userform where the game is actually played with the application hidden in the background and only a certain percentage of the generated puzzle will be placed on the userform (percentage dependant on difficulty selected). The user will then be able to fill in the blanks and then check their answers at the end. But I'm only really interested in feedback of where it's at at the moment as the rest should be fairly easy for me and I have most of it planned out in my head.

Sub GenerateNumbers()
    Dim cell As Range, rng As Range
    Dim sudoku() As Variant
    
    Set rng = Range("A1:I9")
start:
    rng.Value = ""
    sudoku = rng
    
    Randomize
    For i = 1 To 9
        For j = 1 To 9
                'Returns the first row of the 3x3 the current cell is in
            y = Int((i + 2) / 3) + (Abs(1 - Int((i + 2) / 3)) * 2)
            
                'Returns the first col of the 3x3 the current cell is in
            x = Int((j + 2) / 3) + (Abs(1 - Int((j + 2) / 3)) * 2)
            
                'Indexes the row of the current cell
            r = Application.Index(sudoku, i, 0)
            
                'Indexes the column of the current cell
            c = Application.Transpose(Application.Index(sudoku, 0, j))
            
                'Indexes the 3x3 the current cell is in
            xy = Application.Index(sudoku, Application.Transpose(Array(y, y + 1, y + 2)), Array(x, x + 1, x + 2))
            
                'Loop through 1 to 9 until there is at least 1 valid entry identified
            n = 0
            Do
                n = n + 1
                rvalid = False
                cvalid = False
                xy1valid = False
                xy2valid = False
                xy3valid = False
                If UBound(Filter(r, n)) = -1 Then rvalid = True
                If UBound(Filter(c, n)) = -1 Then cvalid = True
                If UBound(Filter(Application.Index(xy, 1, 0), n)) = -1 Then xy1valid = True
                If UBound(Filter(Application.Index(xy, 2, 0), n)) = -1 Then xy2valid = True
                If UBound(Filter(Application.Index(xy, 3, 0), n)) = -1 Then xy3valid = True
            Loop Until n = 9 Or (rvalid = True And cvalid = True And xy1valid = True And xy2valid = True And xy3valid = True)
            
                'If no valid entries are identified then start from scratch
            If rvalid = False Or cvalid = False Or xy1valid = False Or xy2valid = False Or xy3valid = False Then GoTo start
            
                'Fill the current cell with a random valid number
            Do
                n = Int(1 + (Rnd() * 9)) 'I had to increase the upper limit because it was never generating a 9
            Loop Until UBound(Filter(r, n)) = -1 And UBound(Filter(c, n)) = -1 And _
            UBound(Filter(Application.Index(xy, 1, 0), n)) = -1 And UBound(Filter(Application.Index(xy, 2, 0), n)) = -1 And _
            UBound(Filter(Application.Index(xy, 3, 0), n)) = -1 And n < 10 'Just in case a 10 is generated
            
            sudoku(i, j) = n
        Next j
    Next i
    
        'Fill the range with the completed puzzle
    rng = sudoku
End Sub

The next big project is to write a subroutine which solves sudoku puzzles! But one step at a time.

 

[Macropod]

See, for example:
https://windowssecrets.com/forums/s...h-Excel-(2000)?p=580212&viewfull=1#post580212
https://windowssecrets.com/forums/showthread.php/110166-Sudoku?p=633080&viewfull=1#post633080
https://www.di-mgt.com.au/sudoku.html

 

[hezia]

Sub Genarate()
Dim trys As Integer, rng As Range
Set rng = [A1].Resize(9, 9)
Application.ScreenUpdating = False
0 [A1].Resize(9, 9).ClearContents: trys = 0: fill3X3 [D4]
With Application
1 fill3X3 [D1]: trys = trys + 1: If trys > 20 Then GoTo 0 Else If .Sum(rng) <> 2 * 45 Then GoTo 1 Else trys = 0
2 fill3X3 [D7]: trys = trys + 1: If trys > 20 Then GoTo 0 Else If .Sum(rng) <> 3 * 45 Then GoTo 2 Else trys = 0
3 fill3X3 [A4]: trys = trys + 1: If trys > 20 Then GoTo 0 Else If .Sum(rng) <> 4 * 45 Then GoTo 3 Else trys = 0
4 fill3X3 [G4]: trys = trys + 1: If trys > 20 Then GoTo 0 Else If .Sum(rng) <> 5 * 45 Then GoTo 4 Else trys = 0
5 fill3X3 [A1]: trys = trys + 1: If trys > 20 Then GoTo 0 Else If .Sum(rng) <> 6 * 45 Then GoTo 5 Else trys = 0
6 fill3X3 [G1]: trys = trys + 1: If trys > 20 Then GoTo 0 Else If .Sum(rng) <> 7 * 45 Then GoTo 6 Else trys = 0
7 fill3X3 [A7]: trys = trys + 1: If trys > 20 Then GoTo 0 Else If .Sum(rng) <> 8 * 45 Then GoTo 7 Else trys = 0
8 fill3X3 [G7]: trys = trys + 1: If trys > 20 Then GoTo 0 Else If .Sum(rng) <> 9 * 45 Then GoTo 8 Else trys = 0
'in every 3X3 square, check if if current square add 45 to the current sum, if not make it again,if 20 time did not success go back to start
End With
Application.ScreenUpdating = True
End Sub


Sub fill3X3(R As Range)
'make 3X3
Dim myR As Range, C As Range, addR As Range
cnt = 1: Set myR = R.Resize(3, 3): myR.ClearContents
For Each C In myR: cnt = 0 'run for each number and check it
Do
cnt = cnt + 1: F = False
Randomize: num = Int(9 * Rnd + 1)
With WorksheetFunction ' Check no duplicate in cell row, cell column and current 3X3 square
If .CountIf(Cells(1, C.Column).Resize(9, 1), num) > 0 Then F = True
If .CountIf(Cells(C.Row, 1).Resize(1, 9), num) > 0 Then F = True
If .CountIf(myR, num) > 0 Then F = True
End With
If Not F Then C = num
Loop While F And (cnt < 100)
Next
End Sub

 

[hartless43]

Hello everyone,

I've used this forum a lot to poke around and get tip and tricks on things here and there. I consider myself to have a good grasp of the the simpler aspects of VBA in excel, but still have so much to learn. I often set myself little projects to try and revise and expand my skills. So down to it I guess.

I don't have a specific question with this really, I'm more throwing my code out here for review and to see how others would do it differently. I've written a subroutine which generates a completed sudoku puzzle. It works over and over, but it can sometimes take quite some time (ok like 10 seconds or so). I just wonder if there is a more efficient way this could be done.

I've tried to comment my code to make it apparent what I'm doing and why. If you don't get my train of thought along the way please ask me.

Later I'll implement a userform where the game is actually played with the application hidden in the background and only a certain percentage of the generated puzzle will be placed on the userform (percentage dependant on difficulty selected). The user will then be able to fill in the blanks and then check their answers at the end. But I'm only really interested in feedback of where it's at at the moment as the rest should be fairly easy for me and I have most of it planned out in my head.

Sub GenerateNumbers()
    Dim cell As Range, rng As Range
    Dim sudoku() As Variant
   
    Set rng = Range("A1:I9")
start:
    rng.Value = ""
    sudoku = rng
   
    Randomize
    For i = 1 To 9
        For j = 1 To 9
                'Returns the first row of the 3x3 the current cell is in
            y = Int((i + 2) / 3) + (Abs(1 - Int((i + 2) / 3)) * 2)
           
                'Returns the first col of the 3x3 the current cell is in
            x = Int((j + 2) / 3) + (Abs(1 - Int((j + 2) / 3)) * 2)
           
                'Indexes the row of the current cell
            r = Application.Index(sudoku, i, 0)
           
                'Indexes the column of the current cell
            c = Application.Transpose(Application.Index(sudoku, 0, j))
           
                'Indexes the 3x3 the current cell is in
            xy = Application.Index(sudoku, Application.Transpose(Array(y, y + 1, y + 2)), Array(x, x + 1, x + 2))
           
                'Loop through 1 to 9 until there is at least 1 valid entry identified
            n = 0
            Do
                n = n + 1
                rvalid = False
                cvalid = False
                xy1valid = False
                xy2valid = False
                xy3valid = False
                If UBound(Filter(r, n)) = -1 Then rvalid = True
                If UBound(Filter(c, n)) = -1 Then cvalid = True
                If UBound(Filter(Application.Index(xy, 1, 0), n)) = -1 Then xy1valid = True
                If UBound(Filter(Application.Index(xy, 2, 0), n)) = -1 Then xy2valid = True
                If UBound(Filter(Application.Index(xy, 3, 0), n)) = -1 Then xy3valid = True
            Loop Until n = 9 Or (rvalid = True And cvalid = True And xy1valid = True And xy2valid = True And xy3valid = True)
           
                'If no valid entries are identified then start from scratch
            If rvalid = False Or cvalid = False Or xy1valid = False Or xy2valid = False Or xy3valid = False Then GoTo start
           
                'Fill the current cell with a random valid number
            Do
                n = Int(1 + (Rnd() * 9)) 'I had to increase the upper limit because it was never generating a 9
            Loop Until UBound(Filter(r, n)) = -1 And UBound(Filter(c, n)) = -1 And _
            UBound(Filter(Application.Index(xy, 1, 0), n)) = -1 And UBound(Filter(Application.Index(xy, 2, 0), n)) = -1 And _
            UBound(Filter(Application.Index(xy, 3, 0), n)) = -1 And n < 10 'Just in case a 10 is generated
           
            sudoku(i, j) = n
        Next j
    Next i
   
        'Fill the range with the completed puzzle
    rng = sudoku
End Sub

The next big project is to write a subroutine which solves sudoku puzzles! But one step at a time.

I have an Algorithm I use to create a Solution, but it won't run if there are any formulas open, so ask permission to use your code. Thanks, Jerry