vba動態刪除範圍內的複選框

Question

我有一張工作表，如果範圍不爲空，我將添加複選框。 但我也想要的是，如果此範圍減少其值（例如從5到3），我想要刪除這些其他複選框。

例如，我有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