Excel Simple Sudoku Generator

This is a simple Sudoku generator in Excel created and shared for Excel VBA learning purposes. It is a simplified version of the Excel Sudoku Generator posted in this blog a few years ago, and tries to clarify and help understand how the process of generating Sudoku puzzles works in Excel VBA. However, it only creates Sudoku puzzles of low difficulty that can easily be solved uncovering singletons or naked singles (see more about Sudoku solving techniques and solving Sudoku with Excel VBA in this other post). The macro uses decremental generation and ensures that removed numbers do not compromise a unique solution, with the peculiarity of not using any solver to do so. An improved version to create professional Sudoku puzzles is available for download in this other post: Excel Sudoku Pro

 



Sudoku Layout

The first macro creates the characteristic 9x9 Sudoku layout applying some basic VBA formatting properties to the range B2:J10. It basically formats the column width and row height, aligns the cell contents to the center, formats the font, and adds borders to each cell in that range, as well as, a border around each block in the Sudoku grid.

 
  Sub CreateLayout()
  With ActiveSheet
      '.Cells.Clear 'only if applied to an unformatted new sheet (to create layout from scratch)
      .Cells.Interior.Color = vbWhite 'sets the background to white, thus hiding the gridlines
   
      'or alternatively using DisplayGridlines property
      ActiveWindow.DisplayGridlines = False
 
      With .Range("B2:J10")
          .ClearContents
          .ColumnWidth = 5
          .RowHeight = 26
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlCenter
          .Font.Size = 24
          .Borders.LineStyle = xlContinuous
          .BorderAround LineStyle:=xlContinuous, Weight:=xlThick
      End With
 
      .Range("E2:G4").BorderAround LineStyle:=xlContinuous, Weight:=xlThick
      .Range("B5:D7").BorderAround LineStyle:=xlContinuous, Weight:=xlThick
      .Range("H5:J7").BorderAround LineStyle:=xlContinuous, Weight:=xlThick
      .Range("E8:G10").BorderAround LineStyle:=xlContinuous, Weight:=xlThick
  End With
  End Sub
 



 

Sudoku Numbers

The first step in the process to create a Sudoku puzzle using decremental generation is to add the numbers (complying with the Sudoku rules) to fill the entire grid. There are several ways to do that. The easiest way is to create a trivial puzzle based on a simple mathematic formula. The simplest formula leads to a linear sequence as the one shown in the picture below.


Then we can apply transformations that preserve the validity of the puzzle, e.g. shuffling the rows or columns within a given group of blocks, or also the group of blocks altogether. But there are a number of drawbacks using this approach, and filling the grid randomly is preferred instead. There are several ways to do that. Learn more about different techniques to fill the entire Sudoku grid in this other post: Excel Sudoku Generation Techniques - An Overview

The easiest way to understand how VBA loops work to get this done, is probably using brute force. This method consists of trying to put the numbers randomly, until they reach a configuration that allows all of them to be placed correctly (trial and error). As there are so many combinations, that would take a very long time and processing power. A better way to do that is adding each number to random locations one after another, and one to each block or sub-grid within the Sudoku grid. That means adding all the nine 1s first, then the 2s, and so on, until the 8s. There is no need to do it for the 9s as those fit in the remaining nine empty cells. There are several ways to achieve that with Excel VBA. One (hopefully) simple way to put it, is using two loops, one for rows and one for columns, and stepping every 3 cells to locate the starting cell at the top left of each block. Note that we start at row 2 and column 2, as the Sudoku range spans from cell B2 to J10 in the worksheet.

  For GridRow = 2 To 10 Step 3
      For GridCol = 2 To 10 Step 3
                'tasks to do for each block
      Next GridCol
  Next GridRow

Then we start a Do loop to find a place to add the number randomly. The Do loop will repeat until an empty cell where the number can be placed is found (the Sudoku rules apply). The random location within the block is set with the following two variables:

  Randomize        
  CellRow = Int(Rnd * 3) + GridRow
  CellCol = Int(Rnd * 3) + GridCol

 

And here’s how we apply the Sudoku rules to check if the number can be added. Note that we are not checking the unique number in a block, as we are already looping through blocks and will add a single number for each.

  If WorksheetFunction.CountIf(Range("B" & CellRow & ":J" & CellRow), num) = 0 And _
  WorksheetFunction.CountIf(Range(Cells(2, CellCol), Cells(10, CellCol)), num) = 0 Then
            Cells(CellRow, CellCol).Value = num
            Exit Do
  End If

When the number can be added, we exit the Do loop and move to the next block as per the For Next loops explained earlier, and continue the process until all blocks have been visited. Then we move to the next number. However, if a number cannot be placed as per the Sudoku rules, the program will get stuck in that loop. Therefore, we have a LoopCount variable to track the number of loops and take action when a certain number is reached. The threshold of 99 loops is a safe number to exit the loop and take appropriate action. Action will depend on the method we are using.  The easiest method is to start all over and try again when a certain number can no longer be placed. This approach is known as brute force or trial and error. That means, we start all over and try again.

 
  Sub AddNumbers()
  Dim GridRow As Integer, GridCol As Integer
  Dim CellRow As Integer, CellCol As Integer
  Dim num As Integer, LoopCount As Integer
  StartOver:
  Range("B2:J10").ClearContents
  For num = 1 To 8
      For GridRow = 2 To 10 Step 3
      For GridCol = 2 To 10 Step 3
          LoopCount = 0
          Do
          Randomize
          CellRow = Int(Rnd * 3) + GridRow
          CellCol = Int(Rnd * 3) + GridCol
       
          If Cells(CellRow, CellCol) = "" And _
          WorksheetFunction.CountIf(Rows(CellRow), num) = 0 And _
          WorksheetFunction.CountIf(Columns(CellCol), num) = 0 Then
              Cells(CellRow, CellCol) = num
              Exit Do
          End If
       
          LoopCount = LoopCount + 1
          If LoopCount > 99 Then GoTo StartOver
          Loop
      Next GridCol
      Next GridRow
  Next num
  Range("B2:J10").Replace vbNullString, 9
  Range("B2:J10").Copy Sheets("Solution").Range("B2")
  End Sub
 




Sudoku Puzzle

The next step is to remove certain numbers to leave the gaps of the final puzzle. There are several techniques to ensure removed numbers do not compromise a unique solution. Ultimately, a solver can be used to confirm the puzzle is correct and does not have more than one solution. That’s usually not necessary for easy puzzles.

The following macro removes numbers that cannot be placed in any other empty cell within the same row and column. Thus, it generates a puzzle of low difficulty (level Easy), that can be solved with elimination techniques of numbers with a single position (there is only one number left for a given cell). The code in the macro below does the following:

  • Selects a random location in the grid (row and column) that contains a number
  • Loops through every cell (with uCell) in the same row and column to see if the number could be placed in other cell within the same row and column (with CountIf worksheet function)
  • If the number cannot be placed in any other cell within the same row and column (Comp is False), it is safe to remove that number
 
  Sub RemoveRound1()
  Dim CellRow As Integer, CellCol As Integer
  Dim num As Integer, LoopCount As Integer
  Dim uCell As Integer, Comp As Boolean
  LoopCount = 0
  Do
      Randomize
      CellRow = Int(Rnd * 9) + 2
      CellCol = Int(Rnd * 9) + 2
      num = Val(Cells(CellRow, CellCol).Value)
      If num <> 0 Then
          Comp = False
          For uCell = 2 To 10
      
          'Rows
          If uCell <> CellRow And Cells(uCell, CellCol).Value = "" Then
          If WorksheetFunction.CountIf(Range(qRng(uCell, CellCol)), num) = 0 And _
          WorksheetFunction.CountIf(Range("B" & uCell & ":J" & uCell), num) = 0 Then
              Comp = True
              Exit For
          End If
          End If
     
          'Columns
          If uCell <> CellCol And .Cells(CellRow, uCell).Value = "" Then
          If WorksheetFunction.CountIf(Range(qRng(CellRow, uCell)), num) = 0 And _
          WorksheetFunction.CountIf(Range(Cells(uCell,CellCol),Cells(uCell,CellCol)), num) = 0 Then
              Comp = True
              Exit For
          End If
          End If
      Next uCell
      If Comp = False Then
          Cells(CellRow, CellCol)= ""
      Else
          LoopCount = LoopCount + 1
          If LoopCount > 199 Then Exit Do
      End If
      End If
  Loop
  End Sub
 

 

    

Note that we are using a custom function (qRng) to return the range address of the block for a given row and column. That’s used to check the count of a number within each block.

 
  Private Function qRng(r As Integer, c As Integer) As String
    If c < 5 Then
        If r < 5 Then
            qRng = "B2:D4"
        ElseIf r < 8 Then
            qRng = "B5:D7"
        Else
            qRng = "B8:D10"
        End If
    ElseIf c < 8 Then
        If r < 5 Then
            qRng = "E2:G4"
        ElseIf r < 8 Then
            qRng = "E5:G7"
        Else
            qRng = "E8:G10"
        End If
    Else
        If r < 5 Then
            qRng = "H2:J4"
        ElseIf r < 8 Then
            qRng = "H5:J7"
        Else
            qRng = "H8:J10"
        End If
    End If
  End Function
 



Find below other posts about generating and solving Sudoku puzzles with Excel VBA.


Download Excel Simple Sudoku Generator


No comments:

Post a Comment

Popular Posts