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

让我们尝试一下，看看它是否合适。请将以下代码粘贴到您为此目的创建的空白工作簿的常规代码模块（默认情况下为＆＃39; Module1＆＃39;）。它是一个在新工作簿中不存在的模块。不要使用任何现有的。

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行（或其左侧）输入内容 - 任何内容。这是最后一次使用＆＃34;在工作表中的行。

现在将以下代码粘贴到工作表的代码表中，您在其上创建了最后一个＆＃34; used＆＃34;行。它必须完全是代码表 - 没有其他。这是一张已存在的表格。您可以通过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是您将拥有＆＃34;复选框＆＃34;的列。您可以指定任何列。一会儿尝试一下。关键是如果单击任何其他列，代码将不会运行。因此，如果您点击NwsCheck列中的NwsFirstDataRow列，cDatarateChannel *CbsdToSasChannel = cDatarateChannel::create("CbsdToSasChannel"); CbsdToSasChannel->setDelay(0.001);//1ms CbsdToSasChannel->setDatarate(10000);//10Mbps或更低，并且最后一次使用＆＃34;行。点击一下。

由于单元格为空，因此它将被复制为复选框并填充单词＆＃34; False＆＃34;。再次单击它将更改颜色，值将为True。它继续切换。光标向左移动以允许您切换。

您可以向右或向上或向下移动光标。您可以将颜色更改为Excel提供的任何颜色。您可以从我选择的框架更改框架。您可以更改显示的单词。事实上，你几乎无法改变 - 这并不困难。

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

Answer 2

以下是上述的变形。它实际上给你一个复选框字符，而不是写入TRUE或FALSE，而不是写入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

VBA / Excel加速宏添加复选框

2 个答案: