Question

我有一个带有4500个复选框的Excel工作表（我知道，这听起来很愚蠢，但这是针对客户的，请不要问...）。刚刚在下面写下了VBA Sub，以取消所有复选框。到目前为止，它仍然有效，但是它非常慢，需要花费5分钟以上的时间才能检查所有的花键，并且在Sub运行时，整个Excel应用程序都呈灰色冻结。我知道4500复选框很安静，但我不知道这足以使Excel遇到此类麻烦。...有人知道吗？

最佳迈克尔

Sub DeselectAll()
   Application.EnableCancelKey = False
   Application.Calculation = xlCalculationManual
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   Dim wksA As Worksheet
   Dim intRow As Integer

   Set wksA = Worksheets("Companies")
   For intRow = 1 To 4513
      wksA.CheckBoxes("Checkbox_" & intRow).Value = False
   Next
 End Sub

Answer 1

未选择：

Sub DeselectAll()
  With Worksheets("Companies").CheckBoxes
   .Value = xlOff
  End With
End Sub

Answer 2

只是不要循环。

这是选择何时可以提供帮助的好例子：

要设置所有复选框，

Sub dural()
    ActiveSheet.CheckBoxes.Select
    Selection.Value = xlOn
End Sub

要取消选中所有复选框，请执行以下操作：

Sub dural2()
    ActiveSheet.CheckBoxes.Select
    Selection.Value = xlOf
End Sub

（在“表单类型”复选框上进行了测试）

Answer 3

我竖起大拇指的最佳答案是@EvR解决方案。我不是要回答，而是提供了一种解决方法。

我通过在一个简单的3行循环的空白工作簿的空白工作表中添加4000个ComboBox来检查时间（我忘记了在屏幕外进行更新和计算等操作）。我的旧笔记本电脑花了大约10分钟。我没有勇气再来一次。

当我尝试在循环中使用您的代码段时，它只需要3-4秒，而@EvR的解决方案没有循环，而选择则需要1-2秒。这些时间是使用Debug.Print或写入某些单元格所花费的实际时间。在激活工作表的情况下启用屏幕更新，计算和事件后，实际的戏剧会展开。它变得高度不稳定，任何不小心的点击等都会导致excel在2-5分钟内“不响应”状态。

尽管客户和老板总是正确的。一生中，我成功地说服了某人，使工作表上的数百个按钮类似于虚拟的东西。我的想法是在工作表中创建虚拟复选框。正确调整单元格大小，并通过将单元格验证为'= ChrW（＆H2714）'边界，并忽略空白，下面的简单代码可以使其成为一种直通型变通方案。

Public Prvsel As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim isect, Cl As Range
Set isect = Application.Intersect(Target, Range("C1:C4000"))

    If isect Is Nothing Then
    Set Prvsel = Nothing  'Release multiple selection
    Exit Sub
    End If

    If isect.Cells.Count > 1 Then
    Set Prvsel = isect        'storing multiple selection for next click event
    Else
        If Target.Value = ChrW(&H2714) Then
        Target.Value = ""
        Else
        Target.Value = ChrW(&H2714)
        End If
        If Not Prvsel Is Nothing Then
            For Each Cl In Prvsel.Cells
            Cl.Value = Target.Value
            Next Cl
        End If
    End If
End Sub

Answer 4

详细说明@Ahmed AU 解决方案。

选择/取消选择信号/多个虚拟复选框

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim isect As Range
Dim Cl As Range
Dim Prvsel As Range
Set isect = Application.Intersect(Target, Range("C1:C4000"))
If isect Is Nothing Then
Set Prvsel = Nothing  'Release multiple selection
Exit Sub
End If

' Use WINGDING font Chr (254) for checked
' Use WINGDING font Chr (111) for uncheck

If isect.Cells.Count >= 1 Then
Set Prvsel = isect        
    For Each Cl In Prvsel.Cells
            If Cl.Value = Chr(111) Then
                Cl.Value = Chr(254)
                Else
                Cl.Value = Chr(111)
            End If
    Next Cl
End If
'Go to offset cell selection
       Selection.Offset(0, 1).Select
    End Sub

Answer 5

立即重新选择/取消选中复选标记

无需手动移动到其他单元格，可以在End Sub之前添加

Target.Offset(0, 1).Select

对ListObjects的修改：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim isect As Range
Dim Cl As Range
Dim Prvsel As Range
Set isect = Application.Intersect(Target, Worksheets("sheet1").ListObjects("Table1").ListColumns(3).DataBodyRange)

If isect Is Nothing Then
Set Prvsel = Nothing  'Release multiple selection
Exit Sub
End If

' Use WINGDING font Chr (254) for checked
' Use WINGDING font Chr (111) for uncheck

If isect.Cells.Count >= 1 Then
Set Prvsel = isect        
    For Each Cl In Prvsel.Cells
            If Cl.Value = Chr(111) Then
                Cl.Value = Chr(254)
                Else
                Cl.Value = Chr(111)
            End If
    Next Cl
End If

   Selection.Offset(0, 1).Select
End Sub

在Excel中使用VBA遍历复选框非常慢

5 个答案: