Question

我有一张表格，如果范围不为空，我会添加CheckBoxes。但我想要的是动态如果这个范围减小它的值（例如从5变为3）我想删除这些其他CheckBox。

例如，我有4个已填充的行，我的代码添加了4个复选框：

但后来我删除了2行，所以我期待这些复选框也被删除了，但是当我再次运行代码时，我仍然会得到这些复选框：

这是我迄今为止所尝试过的，也是我从THIS回答的部分内容，但它没有成功：

Option Explicit
Sub AddCheckbox()
Dim i As Long, lastrow As Long, rng As Range
Dim ws As Worksheet
Dim obj As OLEObject, cb As MSForms.CheckBox

Set ws = Sheets("Consulta")
lastrow = ws.Cells(Rows.Count, "E").End(xlUp).Row

For i = 5 To lastrow
    If Not IsEmpty(ws.Range("E" & i, "J" & i)) Then
        For Each rng In ws.Range("D" & i)
            ws.OLEObjects.Add "Forms.CheckBox.1", Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height
        Next
    ElseIf IsEmpty(ws.Range("E" & i, "J" & i)) Then
        For Each obj In ws.OLEObjects
        If TypeOf obj.Object Is MSForms.CheckBox Then
            Set cb = obj.Object
            If cb.ShapeRange.Item(1).TopLeftCell.Address = _
                ActiveCell.Address Then obj.Delete
            End If
        Next
    End If
Next

End Sub

任何建议都会有所帮助！我真的相信问题出在以下部分：

If cb.ShapeRange.Item(1).TopLeftCell.Address = _
    ActiveCell.Address Then obj.Delete
End If

Answer 1

这不是很好，但确实有效：

Sub AddCheckbox()

    Const RW_START As Long = 5
    Dim i As Long, lastrow As Long, rng As Range
    Dim ws As Worksheet, o As Object, v
    Dim obj As OLEObject, cb 'As MSForms.CheckBox

    Set ws = Sheets("Consulta")
    lastrow = 500 'ws.Cells(Rows.Count, "E").End(xlUp).Row
    '^^^ not sure what would be the best approach here...

    For i = RW_START To lastrow

        If Application.CountA(ws.Range("E" & i & ":J" & i)) > 0 Then
            With ws.Range("D" & i)
                'not already added a checkbox?
                If Len(.Value) = 0 Then
                    Set o = ws.OLEObjects.Add("Forms.CheckBox.1", _
                                Left:=.Left, Top:=.Top, _
                                Width:=.Width, Height:=.Height)
                    'create a name for the checkbox and link it to the cell
                    v = Application.Max(ws.Cells(RW_START, "D").Resize(1000, 1))
                    v = v + 1
                    o.Name = "cbx_" & v
                    .Value = v
                    .Font.Color = vbWhite
                    Debug.Print i, v
                End If
            End With
        Else
            On Error Resume Next
            ws.Shapes(ws.Range("D" & i).Value).Delete
            On Error GoTo 0
            ws.Range("D" & i).Value = ""
        End If
    Next

End Sub

vba动态删除范围中的复选框

1 个答案: