VBA/Excel Speed up macro adding checkboxes - vba

Question

I need to add checkbox for each row in few documents and I have script for that which working, and that's ok but...
If I have 10k rows then this script it's very slowly. How I can speed up it?CODE:
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
Thanks!

Answer 1

Let's try this and see if it fits. Please paste the following code into a normal code module (by default 'Module1') of a blank workbook you create for this purpose. It is a module which doesn't exist in a new workbook. Don't use any of the existing.
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
In column A, enter something - anything - in row 10 (or thereabouts). This is the last "used" row in your worksheet.
Now paste the following code in the code sheet of the worksheet on which you created a last "used" row. It must be exactly that code sheet - no other. It is a sheet which already exists. You recognise it by the tab's name in the VBE's project explorer window.
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
Now you are all set to test but understand the mechanics first. At the top of the first batch of code you have Enum Nws which specifies one row and two columns. The specified row is NwsFirstDataRow with an assigned value of 2. It means that row 1 is outside the scope of this code. The code will not run when you click in row 1 (presumably a caption row). You could set NwsFirstDataRow to a value of 3, thereby creating 2 header rows which the code won't touch.
The two columns are NwsMainData and NwsCheck. NwsMainData is the column where the last row is measured. If you click below the last row the code will not run. You might find that column A doesn't suit your needs. You can set any other value, thereby specifying another column. The number you set is used for no other purpose but to find the last row. In your test, make sure the column actually has a used row.
NwsCheck is the column where you will have your "check box". You can specify any column. Try it out in a little while. The point is that the code will not run if you click any other column. Therefore, the code will run if you click in the NwsCheck column, at or below NwsFirstDataRow and at or above the last "used" row. Go ahead an click.
Since the cell is empty it will be coloured as a checkbox and filled with the word "False". Click it again and it will change colour and value will be True. It continues to toggle. The cursor moves to the left to allow you to toggle.
You could move the cursor right or up or down. You could change the colours to any colour Excel has on offer. You can change the frame from the one I have selected. You can change the words which are shown. In fact, there is very little you couldn't change - and it isn't difficult.
The question is whether the idea can be adapted to do the job you want a check box to do.

Answer 2

Here is a variation of the above. Instead of writing TRUE or FALSE, it actually gives you a checkbox-character which is either checked or not. The code displays a message box informing you of the status, but the idea is to execute whatever code you want to run instead, based on whether the box is checked or not.
To test this code, add this procedure to the normal code module. Some of the above code will be required for this solution. For the purpose of testing, just have the entire previous code installed. Then add this.
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
Replace the existing event procedure with the one below. The difference is minute, but for quick testing, just replace all of it.
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