Excel Sudoku Randomized?

[JosephGray]

Excel provides a free sudoku game template that comes with varying difficulty levels and helpful instructions. I enjoy playing this sudoku on Excel, but the template is always the same numbers and puzzles. Is there anywhere I can play different sudoku puzzles on Excel?

 

[DacEasy]

Hi, try the below:

 Option Explicit
 
 'https://excelmacrofun.blogspot.com/p/excel-simple-sudoku-generator.html
 Sub CreateLayout()
 Application.DisplayAlerts = False
    Dim Sheet As Worksheet
    For Each Sheet In ActiveWorkbook.Worksheets 'Use a new sheet to perform the calculations
        If Sheet.Name = "Sudoku" Or Sheet.Name = "Solution" Then
            Sheet.Delete
        End If
    Next Sheet
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Sudoku"
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Solution"
    
    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("E8:G10").BorderAround LineStyle:=xlContinuous, Weight:=xlThick
        .Range("H5:J7").BorderAround LineStyle:=xlContinuous, Weight:=xlThick
    
    End With

    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("Sudoku").Range("B2")
    Call RemoveRound1
    End Sub

Private Sub RemoveRound1()
    Sheets("Sudoku").Select
    
    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

  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