Beginn Timer mit Eintragung in Zelle

Hallo!
Ich habe folgendes Problem:
Ich möchte eine Eingabe in A1 machen und nach dem Betätigen der Enter-Taste soll der Timer (hier 1 Minute) starten. Die Startzeit soll in B1 ausgegeben werden und beginnt dann in Sekundenschritten runter zu laufen.
Über dieses Forum wurde mir ein entsprechendes Makro für das automatische Starten zur Verfügung gestellt.
Hier das Makro:
Code:
Code:


Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Fehler
    Const APPNAME = "Worksheet_Change"
    Dim RNG As Range
    Set RNG = Range("A1")
    If Not Intersect(Target, RNG) Is Nothing Then
        If WorksheetFunction.CountA(RNG) = 0 Then
            Application.EnableEvents = False
            Range("B1").ClearContents
        ElseIf WorksheetFunction.CountA(RNG) = 1 Then
            Application.EnableEvents = False
            Range("B1") = "00:01:00"
            Call nexttick
        End If
    End If
    '*** Fehlerbehandlung
Fehler:
    Application.EnableEvents = True
    If Err.Number  0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
        & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Das Makro nexttick lautet wie folgt:
Option Explicit
Dim NextInst As Date
Const TimeDiff="00:00:01"
Sub nexttick ()
On Error GoTo Fehler
Sheets (1).Range("B1").Value=Sheets (1).Range ("B1").Value-TimeValue (TimeDiff)
NextInst=Now+TimeValue (TimeDiff)
Application.OnTime NextInst, "nexttick"
Fehler:
If Err.Number 0 Then
MsgBox "Zeit abgelaufen"
Range("B1").Value="00:01:00"
Range ("A1").Value=""
End If
End Sub
Nun tritt nei mir jedoch folgendes Problem auf:
Ich mache eine Eintragung in A1. Der Timer (00:01:00) wird in B1 eingeblendet und beginnt in Sekundenschritten nach unten zu laufen.
Soweit so gut.
Mache ich jedoch eine weitere Eingabe (z.B. in A2) wird für die Zeit der Eingabe, die Zeit (Timer) angehalten.
Erst, wenn ich meine Eingabe mit der Enter-Taste beende, läuft die Zeit wieder weiter.
Was muss anders gemacht werden, damit die Zeit (Timer), unabhängig von meinen Eingaben, weiter Richtung 0 läuft?
Ich möchte letztendlich herausfinden, wie viele Eingaben in den Zellen (außer A1 -> ist ja meine 1. Eingabezelle) gemacht werden können.
Wenn die Zeit abgelaufen ist, wird ja die Message: "Zeit abgelaufen" eingeblendet. Dann sind keine weiteren Eingaben mehr möglich.
Ich hoffe, mir kann Jemand weiterhelfen.
Danke

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo Fehler Const APPNAME = "Worksheet_Change" Dim RNG As Range Set RNG = Range("A1:A10") If Not Intersect(Target, RNG) Is Nothing Then If WorksheetFunction.CountA(RNG) = 0 Then Application.EnableEvents = False Range("B1:C1").ClearContents ElseIf WorksheetFunction.CountA(RNG) = 1 Then Application.EnableEvents = False Range("B1") = Format(Now, "hh:MM:ss") Range("C1") = "Start" ElseIf WorksheetFunction.CountA(RNG) = RNG.Count Then Application.EnableEvents = False Range("B1") = Format(Now - Range("B1"), "hh:MM:ss") Range("C1") = "Dauer" End If End If '*** Fehlerbehandlung Fehler: Application.EnableEvents = True If Err.Number 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _ & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Hallo Markus,
teste mal damit:

Option Explicit

Private Declare Function SetTimer Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal nIDEvent As Long, _
    ByVal uElapse As Long, _
    ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal nIDEvent As Long) As Long

Private llngTime As Long

Public Sub prcStartTimer()
    llngTime = 10
    Application.StatusBar = " Zeit: " & CStr(llngTime) & " Sekunden"
    Call SetTimer(Application.hwnd, 0, 1000, AddressOf fncTimer)
End Sub

Private Sub prcStopTimer()
    Call KillTimer(Application.hwnd, 0)
End Sub

Private Function fncTimer(ByVal hwnd As Long, ByVal nIDEvent As Long, _
        ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    llngTime = llngTime - 1
    Application.StatusBar = " Zeit: " & CStr(llngTime) & " Sekunden"
    If llngTime = 0 Then
        Call prcStopTimer
        Call MsgBox("Zeit abgelaufen", vbInformation, "Information")
        Application.StatusBar = False
    End If
End Function

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Beginn Timer mit Eintragung in Zelle

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread