Início / coding / Perguntas / 79545211
Accepted
1muflon1
Asked: 2025-03-31 05:58:18 +0800 CST

Tempo de gravação necessário para completar uma linha no Excel usando VBA

  • 772

Gostaria de registrar o tempo que leva para terminar de preencher um formulário no Excel. Criei um formulário, onde tenho as seguintes colunas;

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

Gostaria que o cronômetro iniciasse quando alguém digitasse 1 na coluna inicial e terminasse a gravação quando alguém digitasse 1 na coluna final. O tempo deveria aparecer na coluna de tempo.

Eu escrevi o seguinte código VBA com base em tutoriais online, mas ele não funciona (nada acontece quando eu insiro 1 na primeira coluna da primeira linha (início) e então 1 na primeira linha da última coluna (término), a coluna time permanece vazia). Como o código deve ser ajustado para fazer o que eu preciso que ele faça?

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
excel

1 respostas

  1. Best Answer

    Seu código está bom, apenas certifique-se de que ele esteja diretamente no objeto Worksheet, não no módulo spreadsheet:

    insira a descrição da imagem aqui

    Atualizei seu código um pouco:

    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
    • 3

relate perguntas