Случайный выбор ячеек для очистки содержимого - Excel VBA

Question

В настоящее время у меня есть ряды объединенных ячеек. Мне нужен способ случайного выбора 50% этих ячеек, чтобы очистить содержимое через VBA.

Это то, что я имею до сих пор:

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

Вот мой код:

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

Я догадался, что ваши ячейки объединены строками. Вы не могли очистить их содержимое, потому что обращались только к одному из них. Чтобы решить их все, я использовал метод Worksheet.Range в сочетании с методом Range.Offset и методом Range.Columns.Count. Остальная часть кода в принципе очень похожа на вашу (я просто использовал переменную массива, чтобы пометить ячейки, которые я уже очистил, вместо просмотра их содержимого). Возможной проблемой для такого рода подходов может быть время. Большой список с большим процентом очищаемых данных может занять много времени. Поскольку диапазон, который мы использовали, невелик, проблем не должно быть. Во всяком случае, я добавил таймер, чтобы убедиться, что подпрограмма не go при постоянной попытке случайного выбора еще не выбранных ячеек.

РЕДАКТИРОВАТЬ: здесь тот же код, отредактированный в соответствии с дальнейшими инструкциями :

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