VBA/Excel Speed up macro adding checkboxes

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