excelvba

Recording time it takes to complete a row in Excel using VBA


I would like to record a time it takes to finish filling out a form in Excel. I have created a form, where I have following columns;

start, col1, col2 ..., col8, end, time 

I would like the timer to start when someone enters 1 in start column and finish recording when someone enters 1 in end column, time should appear in column time.

I have written the following VBA code based on tutorials online, but it doesn't work (nothing happens when I enter 1 to first column first row (start) and then 1 to first row of last column (finish), the column time remains empty). How should the code be adjusted to do what I need it to do?

Dim StartTimes As Object ' Dictionary to store start times

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("form") 
    
    Dim StartCol As Integer: StartCol = 1        ' "start" column
    Dim FinishCol As Integer: FinishCol = 10     ' "finish" column
    Dim TimeCol As Integer: TimeCol = 11         ' "time" column

    If StartTimes Is Nothing Then Set StartTimes = CreateObject("Scripting.Dictionary")

    If Not Intersect(Target, ws.Columns(StartCol)) Is Nothing Then
        If Target.Value = 1 Then
            StartTimes(Target.Row) = Now ' Store current timestamp
        End If
    End If

    If Not Intersect(Target, ws.Columns(FinishCol)) Is Nothing Then
        If Target.Value = 1 Then
            If StartTimes.Exists(Target.Row) Then
                ' Calculate elapsed time
                Dim StartTime As Date
                StartTime = StartTimes(Target.Row)
                ws.Cells(Target.Row, TimeCol).Value = Format(Now - StartTime, "hh:mm:ss")
                StartTimes.Remove Target.Row 
            End If
        End If
    End If
End Sub

Solution

  • Your code is fine, just make sure it's directly in the Worksheet object, not in the spreadsheet Module:

    enter image description here

    I've updated your code slightly:

    Option Explicit
    
    Dim dictStartTimes As Object
    
    Private Sub Worksheet_Change(ByVal rngTarget As Range)
        Dim wsForm As Worksheet
        Dim lngStartCol As Long
        Dim lngFinishCol As Long
        Dim lngTimeCol As Long
        Dim dtmStartTime As Date
    
        Set wsForm = ThisWorkbook.Sheets("form")
        lngStartCol = 1
        lngFinishCol = 10
        lngTimeCol = 11
    
        If dictStartTimes Is Nothing Then Set dictStartTimes = CreateObject("Scripting.Dictionary")
    
        On Error GoTo ErrorHandler
    
        If Not Intersect(rngTarget, wsForm.Columns(lngStartCol)) Is Nothing Then
            If rngTarget.Value = 1 Then
                dictStartTimes(rngTarget.Row) = Now
            End If
        End If
    
        If Not Intersect(rngTarget, wsForm.Columns(lngFinishCol)) Is Nothing Then
            If rngTarget.Value = 1 Then
                If dictStartTimes.Exists(rngTarget.Row) Then
                    dtmStartTime = dictStartTimes(rngTarget.Row)
                    wsForm.Cells(rngTarget.Row, lngTimeCol).Value = Format(Now - dtmStartTime, "hh:mm:ss")
                    dictStartTimes.Remove rngTarget.Row
                End If
            End If
        End If
    
    Cleanup:
        Exit Sub
    
    ErrorHandler:
        MsgBox "An error occurred: " & Err.Description
        Resume Cleanup
    End Sub