随机选择单元格清除内容 - Excel VBA

Question

I currently have rows of merged cells. I need a way to randomly select 50% of these cells to clear the contents of through VBA.

This is what I have so far:

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

Set rng = Range("B1:M36")

On Error GoTo ErrHandler

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

For i = 1 To Int(rng.Cells.Count * 0.5)
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

Answer 1

Here is my code:

Sub SubClearMergedCells()

    'Declarations
    Dim WksWorksheet01 As Worksheet
    Dim RngRange01 As Range
    Dim RngTarget As Range
    Dim BlnAlreadyCleared() As Boolean
    Dim LngCounter01 As Long
    Dim LngCellsToBeCleared As Long
    Dim DatTimer As Date
    Dim DblMaximumTime As Double

    'Setting variables.
    Set WksWorksheet01 = Sheets(ActiveSheet.Name)       'put here the sheet where your range is placed
    Set RngRange01 = WksWorksheet01.Range("B5:E11")     'put here the address of the range
    LngCellsToBeCleared = 4                             'put here the number of cells you want to be cleared
    DblMaximumTime = 10                                 'put here the maximum time (in seconds) you want to wait before the code is terminated
    DblMaximumTime = DblMaximumTime / 24 / 3600
    DatTimer = Now + DblMaximumTime

    'Reallocating BlnAlreadyCleared to cover the entire RngRange01.
    ReDim BlnAlreadyCleared(1 To RngRange01.Rows.Count)

    'Repeating until LngCellsToBeCleared is reached.
    Do Until LngCounter01 >= LngCellsToBeCleared

        'Seeding the Rnd function (not strictly necessary, it just "improves the quality" of the random result).
        Randomize

        'Setting RngTarget as a random cell within RngRange01.
        Set RngTarget = RngRange01.Cells(Round(Rnd * (RngRange01.Rows.Count - 1), 0) + 1, 1)

        'Checking if the maximum time has beed reached.
        If Now > DatTimer Then
            MsgBox "The subroutine is taking too much to complete its task. It will be terminated.", , "Maximum time reached"
            Exit Sub
        End If

        'Checking if the range has been already cleared.
        If BlnAlreadyCleared(RngTarget.Row - RngRange01.Row + 1) = False Then

            'Clearing contents of RngTarget merged cell.
            WksWorksheet01.Range(RngTarget, RngTarget.Offset(0, RngRange01.Columns.Count)).ClearContents

            'Setting BlnAlreadyCleared to mark the proper row as cleared.
            BlnAlreadyCleared(RngTarget.Row - RngRange01.Row + 1) = True

            'Setting LngCounter01 for the next cell to be cleared.
            LngCounter01 = LngCounter01 + 1

        End If

    Loop

End Sub

I guessed your cells are merged by rows. You could not clear their contents because you were addressing only one of them. To address them all, i've used the Worksheet.Range method combined with the Range.Offset method and Range.Columns.Count method. The rest of the code is on principle quite similar to your own (i've just used an array variable to mark the cells i've already cleared instead of looking to their contents). A possible problem to these kind of approaches can be time. A greater list with an high percentage of data to be cleared could take a lot. Since the range we've used is small, there should be no problem. Anyway i've added a timer to make sure that the subroutine doesn't go on forever trying to randomly picking the not yet picked cells.

EDIT: here is the same code edited according to the further instructions:

Sub SubClearMergedCellsByValue()

    'Declarations
    Dim WksWorksheet01 As Worksheet
    Dim RngRange01 As Range
    Dim RngTarget As Range
    Dim LngCellsToBeCleared As Long
    Dim DatTimer As Date
    Dim DblMaximumTime As Double

    'Setting variables.
    Set WksWorksheet01 = Sheets(ActiveSheet.Name)       'put here the sheet where your range is placed
    Set RngRange01 = WksWorksheet01.Range("B5:E11")     'put here the address of the range
    LngCellsToBeCleared = 4                             'put here the number of cells you want to be cleared
    DblMaximumTime = 10                                 'put here the maximum time (in seconds) you want to wait before the code is terminated
    DblMaximumTime = DblMaximumTime / 24 / 3600
    DatTimer = Now + DblMaximumTime

    'Reallocating BlnAlreadyCleared to cover the entire RngRange01.
    ReDim BlnAlreadyCleared(1 To RngRange01.Rows.Count)

    'Repeating until LngCellsToBeCleared is reached.
    Do Until Excel.WorksheetFunction.CountBlank(RngRange01.Columns(1)) >= LngCellsToBeCleared

        'Seeding the Rnd function (not strictly necessary, it just "improves the quality" of the random result).
        Randomize

        'Setting RngTarget as a random cell within RngRange01.
        Set RngTarget = RngRange01.Cells(Round(Rnd * (RngRange01.Rows.Count - 1), 0) + 1, 1)

        'Checking if the maximum time has beed reached.
        If Now > DatTimer Then
            MsgBox "The subroutine is taking too much to complete its task. It will be terminated.", , "Maximum time reached"
            Exit Sub
        End If

        'Checking if the range has been already cleared.
        If RngTarget.Value <> "" Then

            'Clearing contents of RngTarget merged cell.
            WksWorksheet01.Range(RngTarget, RngTarget.Offset(0, RngRange01.Columns.Count)).ClearContents

        End If

    Loop

End Sub