在Excel中使用VBA循环复选框非常慢

Question

我有一个包含大约 4500 个复选框的 Excel 表（我知道，这听起来很愚蠢，但它是给客户的，请不要问...）。 只需在下面编写 VBA Sub 以取消选中所有框。到目前为止它可以工作，但速度非常慢，需要超过 5 分钟才能取消选中所有 boces，并且在 Sub 运行时，整个 Excel Applikation 灰显冻结。我知道，4500 Checkboxes 很安静，但我想知道它是否真的足以让 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

详细阐述@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 2

我赞成的最佳答案是@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 3

没有选择：

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

Answer 4

只是不要循环。

这是选择可以提供帮助的一个很好的例子：

设置所有复选框：

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

取消选中所有复选框：

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

（在表单类型的复选框上测试）