Clear a Random Number of Random Cells in a Range-CodePudding

Sub DelThirty()
Dim rng As Range
Dim i As Long, x As Long, y As Long

Set rng = Selection

On Error GoTo ErrHandler

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

For i = 1 To Int(rng.Cells.Count * 0.3)
retry:
    x = WorksheetFunction.RandBetween(1, rng.Rows.Count)
    y = WorksheetFunction.RandBetween(1, rng.Columns.Count)
    If rng.Cells(x, y) <> "" Then
        rng.Cells(x, y).ClearContents
    Else
        GoTo retry
    End If
Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

ErrHandler:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

The above code was written by a user named BARVOBOT who posted it here about 5 years ago. I found this to work in my Sudoku Game to create a puzzle. In this, he wrote for someone who wanted to remove 30% of the numbers. The line that reads "For i = 1 To Int(rng.Cells.Count * 0.3)" is where he placed the 30% and this works great, but I have to change that number to suit my situation manually. For a Medium puzzle, I use 4 different percentages (.40, .43, .49, and .52, so is it possible to use a random feature to select either of the 4 percentages that I use or enter manually? I tried to write a comment to the post he had but it said I did not have enough Reputations to do that, so does anyone have any idea how to fix this to randomly select one of my percentages. Sorry if I didn't get the formatting correct on the code

CodePudding user response：

not really worth a full answer but too much for a comment

as an aside how do you populate the initial 9x9 area for it to remove from?

Sub DelThirty()
Dim rng As Range
Dim i As Long, x As Long, y As Long

Set rng = Selection

Dim myArray(3) As Variant

myArray(0) = 0.4
myArray(1) = 0.43
myArray(2) = 0.49
myArray(3) = 0.52

k = WorksheetFunction.RandBetween(0, 3)

amountOff = myArray(k)

On Error GoTo ErrHandler

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

For i = 1 To Int(rng.Cells.Count * amountOff)
retry:
    x = WorksheetFunction.RandBetween(1, rng.Rows.Count)
    y = WorksheetFunction.RandBetween(1, rng.Columns.Count)
    If rng.Cells(x, y) <> "" Then
        rng.Cells(x, y).ClearContents
    Else
        GoTo retry
    End If
Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

ErrHandler:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

CodePudding user response：

Clear a Random Number of Random Cells in a Range

Option Explicit

' Int((upperbound - lowerbound   1) * Rnd   lowerbound)

Sub ClearRandomly()
    
    ' Write the percentages to an array.
    Dim RandomPercentages() As Variant
    RandomPercentages = VBA.Array(0.4, 0.43, 0.49, 0.52)

    ' Validate the selection.
    If Not TypeOf Selection Is Range Then
        MsgBox "The selection is not a range.", vbCritical
        Exit Sub
    End If
    
    ' Reference the range ('rg') and write its various counts to variables.
    Dim rg As Range: Set rg = Selection.Areas(1)
    Dim rCount As Long: rCount = rg.Rows.Count
    Dim cCount As Long: cCount = rg.Columns.Count
    Dim CellsCount As Long: CellsCount = rCount * cCount
    
    ' Determine the random percentage ('RandomPercentage').
    Dim RandomPercentage As Double: RandomPercentage _
        = RandomPercentages(Int((UBound(RandomPercentages)   1) * Rnd))
    
    ' Determine the number of cells to be cleared ('ClearCellsCount').
    Dim ClearCellsCount As Long
    ClearCellsCount = Int(CellsCount * RandomPercentage)
    
    ' Validate the number of cells to be cleared.
    If ClearCellsCount = 0 Then
        MsgBox "Please select more cells.", vbCritical
        Exit Sub
    End If
    
    ' Write the numbers from one to the number of cells
    ' to a 1D one-based array ('RndCells').
    Dim RndCells() As Long: ReDim RndCells(1 To CellsCount)
    Dim n As Long
    For n = 1 To CellsCount
        RndCells(n) = n
    Next n
    
    ' Shuffle the array.
    Dim Temp As Long, i As Long, j As Long
    For i = CellsCount To 1 Step -1
        Temp = RndCells(i)
        j = Int(i * Rnd)   1
        RndCells(i) = RndCells(j)
        RndCells(j) = Temp
    Next
    
    ' Write the values from the range to a 2D one-based array.
    Dim Data() As Variant: Data = rg.Value
    
    ' Randomly determine if the data will be cleared by rows or by columns.
    Dim ByColumn As Long: ByColumn = Int(2 * Rnd)
    
    ' Clear the random elements.
    Dim Num As Long
    If ByColumn = 0 Then ' by rows
        For n = 1 To ClearCellsCount
            Num = RndCells(n) - 1
            Data(Int(Num / cCount)   1, Num Mod cCount   1) = Empty
        Next n
    Else ' by columns
        For n = 1 To ClearCellsCount
            Num = RndCells(n) - 1
            Data(Num Mod rCount   1, Int(Num / rCount)   1) = Empty
        Next n
    End If
    
    ' Write the modified values from the 2D array back to the range.
    rg.Value = Data
    
    ' Create the message string.
    Dim MsgString As String
    MsgString = "Clear Randomly Stats" & vbLf & vbLf _
        & "Random Percentage: " & RandomPercentage & vbLf _
        & "Range Address: " & rg.Address(0, 0) & vbLf _
        & "Number of Rows: " & rCount & vbLf _
        & "Number of Columns: " & cCount & vbLf _
        & "Number of Cells: " & CellsCount & vbLf _
        & "Number of Cells Cleared: " & ClearCellsCount & vbLf _
        & "Cells Cleared: " & IIf(ByColumn = 0, "By Rows", "By Columns")
    
    ' Inform.
    MsgBox MsgString, vbInformation

End Sub