使用 VBA 代码在多行上启用复选框

Question

enter image description here我有一个电子表格，每行有 3 个复选框选项，我创建了一个 VBA 以在创建复选框后禁用其他 2 个复选框（因此只能选中 1 个复选框），但我的解决方案仅限适用于一行，我需要一些帮助来重写它，以便它适用于所有行。 （我是 VBA 新手）。

我使用的代码是这样的：

Private Sub CheckBox1_Click()
If CheckBox1.Value = True Then
  CheckBox2.Value = False
  CheckBox2.Enabled = False
  CheckBox3.Value = False
  CheckBox3.Enabled = False
Else
  CheckBox2.Value = False
  CheckBox2.Enabled = True
  CheckBox3.Value = False
  CheckBox3.Enabled = True
End If
End Sub
Private Sub CheckBox2_Click()
If CheckBox2.Value = True Then
  CheckBox1.Value = False
  CheckBox1.Enabled = False
  CheckBox3.Value = False
  CheckBox3.Enabled = False
Else
  CheckBox1.Value = False
  CheckBox1.Enabled = True
  CheckBox3.Value = False
  CheckBox3.Enabled = True
End If
End Sub

Private Sub CheckBox3_Click()
If CheckBox3.Value = True Then
  CheckBox1.Value = False
  CheckBox1.Enabled = False
  CheckBox2.Value = False
  CheckBox2.Enabled = False
Else
  CheckBox1.Value = False
  CheckBox1.Enabled = True
  CheckBox2.Value = False
  CheckBox2.Enabled = True
End If
End Sub

Answer 1

您没有说明您的工作表复选框类型...请测试下一个解决方案。它将能够处理两种工作表复选框类型：

1. 在标准模块中复制这两个Subs：

Public Sub CheckUnCheckRow(Optional strName As String)
  Dim sh As Worksheet, s As CheckBox, chK As OLEObject ' MSForms.CheckBox
   Set sh = ActiveSheet
  If strName <> "" Then
    Set chK = sh.OLEObjects(strName) '.OLEFormat.Object
    solveCheckRow chK.Object.Value, sh, Nothing, chK
  Else
    Set s = sh.CheckBoxes(Application.Caller)
    solveCheckRow s.Value, sh, s
  End If
End Sub
Sub solveCheckRow(boolVal As Long, sh As Worksheet, chF As CheckBox, Optional chK As OLEObject)
 Dim s As CheckBox, oObj As OLEObject, iCount As Long
 
    If Not chF Is Nothing Then
        For Each s In sh.CheckBoxes
            If chF.TopLeftCell.Address <> s.TopLeftCell.Address Then
                If s.TopLeftCell.Row = chF.TopLeftCell.Row Then
                    s.Value = IIf(boolVal = -4146, 1, -4146): iCount = iCount + 1
                    If iCount = 2 Then Exit Sub
                End If
            End If
        Next
    ElseIf Not chK Is Nothing Then
        For Each oObj In sh.OLEObjects
            If oObj.TopLeftCell.Address <> chK.TopLeftCell.Address Then
                If oObj.TopLeftCell.Row = chK.TopLeftCell.Row Then
                  boolStopEvents = True
                    oObj.Object.Value = IIf(boolVal = 0, True, False): iCount = iCount + 1
                  boolStopEvents = False
                    If iCount = 2 Then Exit Sub
                End If
            End If
        Next
    End If
End Sub

1. 对于表单复选框类型：

一）。手动将第一个子分配给所有表单类型复选框（右键单击 - 分配宏，选择 CheckUnCheckRow 并按 OK）。

b)。自动分配宏：

  Dim sh As Worksheet, s As CheckBox
  
  Set sh = ActiveSheet ' use here your sheet keeping the check boxes
  For Each s In sh.CheckBoxes
        s.OnAction = "'" & ThisWorkbook.Name & "'!CheckUnCheckRow"
  Next
End Sub

如果您的复选框已经分配了一个宏，请在表单复选框部分调整CheckUnCheckRow，以便也调用该宏...

1. 对于 ActiveX 复选框：

一）。在标准模块之上（在声明区域）创建一个Public 变量：

Public boolStopEvents

b)。手动调整所有 ActiveX 复选框 Click 或 Change 事件，如下例所示：

Private Sub CheckBox1_Click()
   If Not boolStopEvents Then CheckUnCheckRow "CheckBox1"
End Sub
Private Sub CheckBox2_Click()
   If Not boolStopEvents Then CheckUnCheckRow "CheckBox2"
End Sub
Private Sub CheckBox3_Click()
   If Not boolStopEvents Then CheckUnCheckRow "CheckBox3"
End Sub

等等……

c)。或者，使用下一段代码，只需单击一下即可完成所有操作：

Sub createEventsAllActiveXCB()
   Dim sh As Worksheet, oObj As OLEObject, strCode As String, ButName As String
   
   Set sh = ActiveSheet 'use here your sheet keeping ActveX check boxes
   For Each oObj In sh.OLEObjects
        If TypeName(oObj.Object) = "CheckBox" Then
            ButName = oObj.Name
            strCode = "Private Sub " & ButName & "_Click()" & vbCrLf & _
                      "     If Not boolStopEvents Then CheckUnCheckRow """ & ButName & """" & vbCrLf & _
                      "End Sub"
            addClickEventsActiveXChkB sh, strCode
        End If
   Next
End Sub

无论如何，代码可以被简化，以便只处理一个类型的复选框。如果您打算使用它并且看起来太浓密，我只能将它调整为您喜欢的类型。就像它一样，代码处理这两种复选框类型，如果两者都存在于工作表上......

保存工作簿并开始使用复选框。但是，当您谈论一行中的复选框时，它们的所有树必须具有相同的TopLeftCell.Row...

Answer 2

您可能应该只使用 Radios，它会简单得多。

如果您打算这样做，则需要删除所有框，然后输入此代码。它将创建并命名您的框并在单击时为其分配代码。

好的，这需要进入您的工作表模块：

Sub Worksheet_Activate()
    'Change Module2 to whatever the module name you are using is.
    Module2.ActivateCheckBoxes ActiveSheet
End Sub

接下来的内容将进入您从工作表模块引用的模块。

Sub ActivateCheckBoxes(sht As Worksheet)
    If sht.CheckBoxes.Count = 0 Then
        CreateCheckBoxes sht
    End If
    Dim cb As CheckBox
    
    For Each cb In sht.CheckBoxes
        'You may be able to pass sht as an object, It was giving me grief though
        cb.OnAction = "'Module2.CheckBoxClick """ & cb.name & """, """ & sht.name & """'"
    Next cb
End Sub

Sub CreateCheckBoxes(sht As Worksheet)
    Dim cell As Range
    Dim chkbox As CheckBox
    With sht
        Dim i As Long
        Dim prevrow As Long
        prevrow = 0
        For Each cell In .Range("B2:D5") 'Change this to whatever range you want.
            If prevrow < cell.row Then
                prevrow = cell.row
                i = 0
            End If
            Set chkbox = .CheckBoxes.Add(cell.Left, cell.Top, 30, 6)
            With chkbox
                .name = "CheckBox" & i & "_" & cell.row
                .Caption = ""
            End With
            
            i = i + 1
        Next cell
    End With                             
End Sub

Sub CheckBoxClick(chkname As String, sht As String)
    Dim cb As CheckBox
    With Worksheets(sht)

        For Each cb In .CheckBoxes
            If Split(cb.name, "_")(1) Like Split(chkname, "_")(1) And Not cb.name Like chkname Then
                cb.Value = -4146
            End If
        Next cb
    End With
            
End Sub