Checkbox Timestamp with VBA

[Agnarr]

Hello everyone!
I have a huge problem.
we utilize a "to-do" list with checkboxes that are inserted into each new sheet with the following code:

Sub InsertCheckBox()
    Dim rng As Range
    Dim chkBox As CheckBox
    Dim cell As Range
    Dim i As Integer
    
    ' Set the range where you want to insert checkboxes
    Set rng = Range("A4:A140") ' Modify this range as needed
    
    ' Loop through each cell in the range
    For Each cell In rng
        ' Insert a checkbox
        Set chkBox = ActiveSheet.CheckBoxes.Add(cell.Left, cell.Top, cell.Width, cell.Height)
        
        ' Link the checkbox to the cell behind it
        With chkBox
            .LinkedCell = cell.Offset(0, 0).Address
            .Caption = ""
            .Name = "CheckBox" & i
            i = i + 1
        End With
    Next cell
End Sub

we need to show the timestamp of when a checkbox is checked in column F.
Closer I came to fix the problem is with this Code:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim rng As Range
    Dim cell As Range
    Dim cb As CheckBox
    Dim checkBoxRange As Range
    Dim intersectRange As Range

    Application.EnableEvents = False 'Disable events to prevent infinite loop

    ' Define the range where CheckBoxes are located
    Set checkBoxRange = Sh.Range("B1:B10") ' Modify this range according to your CheckBox locations

    ' Check if any cell in column A has changed
    If Not Intersect(Target, Sh.Columns("A")) Is Nothing Then
        For Each cell In Intersect(Target, Sh.Columns("A"))
            ' Update corresponding cell in column F based on the value in column A
            If cell.Value = True Then
                cell.Offset(0, 5).Value = Now
                cell.Offset(0, 5).NumberFormat = "dd/mm hh:mm"
            Else
                cell.Offset(0, 5).ClearContents
            End If
        Next cell
    End If

    ' Check if any CheckBox state has changed within the checkBoxRange
    Set intersectRange = Intersect(Target, checkBoxRange)
    If Not intersectRange Is Nothing Then
        For Each cell In intersectRange
            ' Find the corresponding CheckBox within the checkBoxRange
            Set cb = Nothing
            On Error Resume Next
            Set cb = Sh.CheckBoxes(cell.TopLeftCell.Top, cell.TopLeftCell.Left)
            On Error GoTo 0
            
            If Not cb Is Nothing Then
                If cb.Value = 1 Then
                    cell.Offset(0, 5).Value = Now
                    cell.Offset(0, 5).NumberFormat = "dd/mm hh:mm"
                Else
                    cell.Offset(0, 5).ClearContents
                End If
            End If
        Next cell
    End If

    Application.EnableEvents = True 'Enable events again
End Sub

it works when i type (or paste) "TRUE" on the column A, but not when the value changes to "TRUE" by pressing a checkbox.
Any help would be greatly appreciated....

 

[bobsan42]

May I suggest a slightly different approach - discard completely Workbook_SheetChange event and directly use the Checkbox click event. See if it works for you.
Create a normal public code module and put this code inside it:

Option Explicit

Sub recordCheckBoxChange()
    Dim cb As CheckBox
    Set cb = ActiveSheet.CheckBoxes(Application.Caller)
    If cb.Value = 1 Then
        With ActiveSheet.Range(cb.LinkedCell).Offset(0, 5)
            .Value = Now()
            .NumberFormat = "dd/mm hh:mm"
        End With
        cb.Enabled = False 'This can disable the checkbox to prevent further changes
    End If
    Set cb = Nothing
End Sub

Modify the above code to fit your needs.
Keep the other procedure, just add a line to it to handle the click event: .OnAction = "recordCheckBoxChange"

Sub InsertCheckBox()
    Dim rng As Range
    Dim chkBox As CheckBox
    Dim cell As Range
    Dim i As Integer
   
    ' Set the range where you want to insert checkboxes
    Set rng = Range("A4:A140") ' Modify this range as needed
   
    ' Loop through each cell in the range
    For Each cell In rng
        ' Insert a checkbox
        Set chkBox = ActiveSheet.CheckBoxes.Add(cell.Left, cell.Top, cell.Width, cell.Height)
       
        ' Link the checkbox to the cell behind it
        With chkBox
            .OnAction = "recordCheckBoxChange"
            .LinkedCell = cell.Offset(0, 0).Address
            .Caption = ""
            .Name = "CheckBox" & i
            i = i + 1
        End With
    Next cell
End Sub

 

[Agnarr]

May I suggest a slightly different approach - discard completely Workbook_SheetChange event and directly use the Checkbox click event. See if it works for you.
Create a normal public code module and put this code inside it:

Option Explicit

Sub recordCheckBoxChange()
    Dim cb As CheckBox
    Set cb = ActiveSheet.CheckBoxes(Application.Caller)
    If cb.Value = 1 Then
        With ActiveSheet.Range(cb.LinkedCell).Offset(0, 5)
            .Value = Now()
            .NumberFormat = "dd/mm hh:mm"
        End With
        cb.Enabled = False 'This can disable the checkbox to prevent further changes
    End If
    Set cb = Nothing
End Sub

Modify the above code to fit your needs.
Keep the other procedure, just add a line to it to handle the click event: .OnAction = "recordCheckBoxChange"

Sub InsertCheckBox()
    Dim rng As Range
    Dim chkBox As CheckBox
    Dim cell As Range
    Dim i As Integer
  
    ' Set the range where you want to insert checkboxes
    Set rng = Range("A4:A140") ' Modify this range as needed
  
    ' Loop through each cell in the range
    For Each cell In rng
        ' Insert a checkbox
        Set chkBox = ActiveSheet.CheckBoxes.Add(cell.Left, cell.Top, cell.Width, cell.Height)
      
        ' Link the checkbox to the cell behind it
        With chkBox
            .OnAction = "recordCheckBoxChange"
            .LinkedCell = cell.Offset(0, 0).Address
            .Caption = ""
            .Name = "CheckBox" & i
            i = i + 1
        End With
    Next cell
End Sub

Man... Thank you very much! I wasted hours yesterday trying to figure this out.

 

[bobsan42]

Glad I could help.