特定のセルにActiveXチェックボックスを作成

Question

私のシート1では、列Aにいくつかの値があり、特定のセルのシート2のすべての値に対してアクティブXチェックボックスを作成する必要があります。まず、Active Xチェックボックスが値の有無をチェックする必要があります。存在しない場合は、作成する必要があります。私はすでに以下のコードを試しましたが、重複したチェックボックスを作成しています。

Sub Addcheckbox() 
Dim rng As Range, cell As Range 
Dim rr As Integer 
Dim tf As Boolean 
Dim shpTemp As Shape 

Set rng = Range("A1:A8") 
Set Destrng = Range("A2:A9") 
rr = 2 
For Each cell In Worksheets("Sheet1").Range("A1:A8") 
    If Not IsEmpty(cell.Value) Then 
    With ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", _ 
     Left:=51.75, Top:=183, Width:=120, Height:=19.5) 
     .Object.Caption = cell.Value 
    End With 
    End If 
rr = rr + 1 
Next cell 
End Sub 

確認する方法かどうか、既にシートに存在するかどうかキャプション名を持つ私は、チェックボックスをチェックするため、このコードを試してみました

..しかし、その動作していないActiveXのチェックボックス..

Function shapeExists(ByRef shapename As String) As Boolean 

    shapeExists = False 
    Dim sh As Shape 
    For Each sh In ActiveSheet.Shapes 
     If sh.name = shapename Then 
      shapeExists = True 
      Exit Function 
     End If 
    Next sh 


End Function 

Answer 1

ActiveXチェックボックスはOleObjectsです。これはあなたが試みていることですか？

また、同じ場所に作成される正しい.Topを指定する必要があります。私の使用方法を参照してくださいTop:=cell.Top

Sub Sample() 
    Dim rng As Range, cell As Range 
    Dim rr As Integer 
    Dim tf As Boolean 
    Dim shpTemp As Shape 

    Set rng = Range("A1:A8") 
    Set Destrng = Range("A2:A9") 

    rr = 2 

    For Each cell In Worksheets("Sheet1").Range("A1:A8") 
     If Not IsEmpty(cell.Value) Then 
      If Not CBExists(cell.Value) Then '<~~ Check if the checkbox exists 
       With ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", _ 
         Left:=51.75, Top:=cell.Top, Width:=120, Height:=19.5) 
         .Object.Caption = cell.Value 
       End With 
      End If 
     End If 
     rr = rr + 1 
    Next cell 
End Sub 

'~~> Function to check if the checkbox exists 
Function CBExists(s As String) As Boolean 
    Dim oleObj As OLEObject 
    Dim i As Long 

    For i = 1 To Worksheets("Sheet1").OLEObjects.Count 
     If s = Worksheets("Sheet1").OLEObjects(i).Object.Caption Then 
      CBExists = True 
      Exit Function 
     End If 
    Next i 
End Function