VBA/Excel加快宏添加复选框

Question

我需要添加复选框在每一行中的几个文件，我有脚本的工作，这没关系，但... 如果我有10K行那么这个脚本它是非常缓慢。我如何加快它？代码：

Sub AddCheckBoxes() 
    Dim chk As CheckBox 
    Dim myRange As Range, cel As Range 
    Dim ws As Worksheet 

    Set ws = Sheets("") 'adjust sheet to your need 
    Set myRange = ws.Range("A65:A75") ' adjust range to your needs 

    For Each cel In myRange 
     Set chk = ws.CheckBoxes.Add(cel.Left, cel.Top, 30, 6) 'you can adjust left, top, height, width to your needs 
     With chk 
      .Caption = "Valid" 
      .LinkedCell = cel.Range("B65:B75").Address 
     End With 
    Next 
End Sub 

谢谢！

Answer 1

让我们试试看看它是否合适。请将以下代码粘贴到您为此创建的空白工作簿的普通代码模块（默认为“Module1”）。这是一个不存在于新工作簿中的模块。不要使用任何现有的。

Option Explicit 

Enum Nws       ' Worksheet rows & columns 
    ' 20 Apr 2017 
    NwsFirstDataRow = 2    ' adjust as required 
            ' Columns: 
    NwsMainData = 1     ' (= A) Test for used range 
    NwsCheck = 7     ' (= G) column for Check cell 
End Enum 

Enum Nck       ' CheckBox 
    ' 20 Apr 2017 
    NckFalse 
    NckTrue 
    NckNotSet      ' any value other than True or False 
End Enum 

Sub SetCheckCell(Target As Range) 
    ' 20 Apr 2017 

    Dim TgtVal As Nck 

    With Target 
     If Len(.Value) Then 
      Select Case .Value 
       Case True 
        TgtVal = NckFalse 
       Case False 
        TgtVal = NckTrue 
       Case Else 
        TgtVal = NckNotSet 
      End Select 
     Else 
      TgtVal = NckNotSet 
     End If 

     If TgtVal = NckNotSet Then 
      SetBorders Target 
      TgtVal = NckFalse 
     End If 

     .Value = CBool(Array(0, -1)(TgtVal)) 
     With .Interior 
      .Pattern = xlSolid 
      .PatternColorIndex = xlAutomatic 
      .ThemeColor = Array(xlThemeColorAccent6, xlThemeColorAccent3)(TgtVal) 
      .TintAndShade = 0.399945066682943 
      .PatternTintAndShade = 0 
     End With 
     .Offset(0, -1).Select 
    End With 
End Sub 

Private Sub SetBorders(Rng As Range) 
    ' 12 Apr 2017 

    Dim Brd As Long 

    For Brd = xlEdgeLeft To xlInsideHorizontal 
     SetBorder Rng, Brd 
    Next Brd 
    Rng.Borders(xlDiagonalDown).LineStyle = xlNone 
    Rng.Borders(xlDiagonalUp).LineStyle = xlNone 
End Sub 

Private Sub SetBorder(Rng As Range, _ 
         Brd As Long) 
    ' 12 Apr 2017 

    With Rng.Borders(Brd) 
     .LineStyle = xlContinuous 
     .ThemeColor = 1 
     .TintAndShade = -0.349986266670736 
     .Weight = xlMedium 
    End With 
End Sub 

在A列中，在第10行（或其附近）输入东西 - 任何东西。这是工作表中最后一个“used”行。

现在将以下代码粘贴到您创建最后一个“已用”行的工作表的代码表中。它必须是完全的代码表 - 别无他法。这是一张已经存在的表格。您可以在VBE的项目浏览器窗口中通过选项卡的名称来识别它。

Option Explicit 

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    ' 20 Apr 2017 

    Dim Rng As Range     ' used range (almost) 
    Dim Rl As Long      ' last row 

    Application.EnableEvents = False 
    With Target.Worksheet 
     Rl = .Cells(.Rows.Count, NwsMainData).End(xlUp).Row 
     Set Rng = .Range(.Cells(NwsFirstDataRow, NwsCheck), .Cells(Rl, NwsCheck)) 
     If Not Application.Intersect(Target, Rng) Is Nothing Then 
      SetCheckCell .Cells(Target.Row, NwsCheck) 
     End If 
    End With 
    Application.EnableEvents = True 
End Sub 

现在你们都准备测试，但首先要了解机制。在第一批代码的顶部有Enum Nws，它指定了一行和两列。指定的行是NwsFirstDataRow，指定的值为2.它表示第1行不在此代码的范围内。当您点击第1行时（大概是标题行），代码将不会运行。您可以将NwsFirstDataRow设置为3，从而创建代码不会触及的2个标题行。

这两列是NwsMainData和NwsCheck。 NwsMainData是测量最后一行的列。如果你点击最后一行下面的代码将不会运行。您可能会发现A列不适合您的需求。您可以设置任何其他值，从而指定另一列。您设置的号码不能用于其他目的，只能查找最后一行。在你的测试中，确保该列实际上有一个使用过的行。

NwsCheck是您将有“复选框”的列。您可以指定任何列。稍后尝试一下。重点是如果您单击任何其他列，代码将不会运行。因此，如果您在NwsCheck列中单击NwsFirstDataRow或低于最后一个“已用”行，则代码将运行。继续点击。

由于单元格是空的，它将作为复选框着色并填充单词“False”。再次点击它会改变颜色和值将是真实的。它继续切换。光标向左移动让您切换。

您可以将光标向右或向上或向下移动。您可以将颜色更改为Excel提供的任何颜色。您可以更改我选择的框架。您可以更改显示的文字。事实上，你很难改变 - 这并不难。

问题是这个想法是否可以适应你想做复选框的工作。

Answer 2

这是以上的变化。它不会写入TRUE或FALSE，它实际上会给你一个复选框 - 字符，不管是否选中。代码显示一个消息框，通知您状态，但想法是根据是否选中该框来执行您想要运行的任何代码。

要测试此代码，请将此过程添加到常规代码模块。这个解决方案需要上面的一些代码。为了进行测试，只需安装完整的以前的代码。然后添加这个。

Function SetCheck(Cell As Range) As Boolean 
    ' 21 Apr 2017 

    Dim Fun As Integer 
    Dim Chars() As Variant 
    Dim Mark As Integer      ' character current displayed 

    Chars = Array(168, 254)     ' unchecked/checked box 
    With Cell 
     If Len(.Value) Then Mark = AscW(.Value) 
     Fun = IIf(Mark = Int(Chars(0)), 1, 0) 
     With .Font 
      .Name = "Wingdings" 
       .Size = 11 
     End With 
     .Value = ChrW(Chars(Fun)) 
     .Offset(0, 1).Select 
    End With 

    SetCheck = CBool(Fun) 
End Function 

将现有的事件过程替换为下面的过程。差别很小，但为了快速测试，只需更换全部。

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    ' 21 Apr 2017 

    Dim Rng As Range     ' used range (almost) 
    Dim Rl As Long      ' last row 
    Dim Chk As Boolean 

    Application.EnableEvents = False 
    With Target.Worksheet 
     Rl = .Cells(.Rows.Count, NwsMainData).End(xlUp).Row 
     Set Rng = .Range(.Cells(NwsFirstDataRow, NwsCheck), .Cells(Rl, NwsCheck)) 
     If Not Application.Intersect(Target, Rng) Is Nothing Then 
'   SetCheckCell .Cells(Target.Row, NwsCheck) 
      Chk = SetCheck(Target.Cells(1)) 
      MsgBox "The checkbox is now " & IIf(Chk, "", "un") & "checked" 
     End If 
    End With 
    Application.EnableEvents = True 
End Sub