VBA/Excel加速宏添加复选框
我需要在少数几个文档中为每一行添加复选框,并且我已经有了工作的脚本,这没关系,但是。。。 如果我有10k行,那么这个脚本非常慢。如何加快速度?代码:VBA/Excel加速宏添加复选框,vba,performance,excel,Vba,Performance,Excel,我需要在少数几个文档中为每一行添加复选框,并且我已经有了工作的脚本,这没关系,但是。。。 如果我有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
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
谢谢 让我们试试这个,看看是否合适。请将以下代码粘贴到为此目的创建的空白工作簿的普通代码模块(默认为“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行(或其附近)输入某物-任何东西。这是工作表中最后一行“已使用”
现在,将以下代码粘贴到工作表的代码表中,您在该工作表上创建了最后一个“已使用”行。它一定就是那个代码表-没有其他。这是一张已经存在的表。您可以通过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提供的任何颜色。您可以从我选择的帧更改帧。您可以更改显示的单词。事实上,没有什么是你不能改变的——这并不困难
问题是这个想法是否能适应你想要一个复选框做的工作。这里是上面的一个变体。它实际上提供了一个复选框字符,可以是选中的,也可以是不选中的,而不是写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
将
Application.screenUpdate=False
添加到code@ShaiRado但请不要忘记将其设置回Application.screenUpdatement=True
beforeEnd Sub
10000复选框添加到工作簿的卷中,仅因为其大小而使其变慢。考虑只创建一个复选框,并将它移到使用WorkSeTeSelePosivchange事件单击的行。用一个表来做它,只要需要,就简单地将该列复制到所需的表中。