在特定单元格中创建ActiveX复选框

时间:2017-06-09 05:59:23

标签: excel excel-vba checkbox vba

在我的工作表1中,A列有一些值,我需要为特定单元格中Sheet 2中的所有值创建一个Active 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

1 个答案:

答案 0 :(得分: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