Timer laten lopen in een cel

[danny147]

Beste,

Ik heb volgende code om mijn bestandje te refreshen na 15 min

Application.OnTime DateAdd("s", 900, Time), "Barcodes"

Kan ik nu in cel A10 ook zien hoelang het nog duurt vooraleer hij refreshed ?

 

[SjonR]

kijk eens hier:


http://www.helpmij.nl/forum/showthread.php/918051-Countdown-timer-in-Excel?highlight=timer

 

[danny147]

Beste SjonR

Dat is niet wat ik wens

Na 15 min refreshed mijn bestandje, ik wil dan een teller zien in A10 die 900 sec aftelt naar 0

 

[edmoor]

Dat is precies wat mijn voorbeeld in dat draadje doet.
Het aantal seconden en uit te voeren actie kan je zelf aanpassen.

 

[SjonR]

De kans dat het draadje waar ik naar verwijs precies over cel A10 en 15 gaat acht ik ook klein, maar je kan de methodiek toch gebruiken naar je eigen wens.

 

[danny147]

Beste,

Heb een voorbeeldje in elkaar gestoken waarbij hij in cel E2 eentje bijtelt na 1 min en in cel C2 de resterende tijd laat zien bij volgende refresh
Echter gaat het niet zo goed want na 1 min gaat er telkens 2 sec af van de resterende tijd en daarna weer juist.

 

[HSV]

Test het eens met deze codes.

Public t
Public t2
Sub aftellen()
Application.ScreenUpdating = False
t = DateAdd("s", 30, Time)
 Blad1.Range("C2").Value = Format(30, "00:00:00")
 Application.OnTime t, "aftellen"
   StartTimer1
 DoEvents
End Sub


Sub StartTimer1()
 If Range("c2") > 0 Then
   Range("C2").Value = Range("C2").Value - TimeValue("00:00:01")
     t2 = DateAdd("s", 1, Time)
    Application.OnTime t2, "StartTimer1"
 End If
End Sub


Sub stoptimer()
Application.OnTime t2, "StartTimer1", , False
Application.OnTime t, "aftellen", , False
End Sub

 

[danny147]

Bedankt HSV,

Deze werkt naar behoren.

 

[danny147]

Beste,

Graag zou ik de timer op 900 sec willen plaatsen, maar dan gaat het niet zo goed
Hij begint dan af te tellen vanaf 9 min

Gebruik nu deze code in het origineel bestandje

Public t
Public t2

Sub StartTimer1()
 If Range("c2") > 0 Then
   Range("C2").Value = Range("C2").Value - TimeValue("00:00:01")
     t2 = DateAdd("s", 1, Time)
    Application.OnTime t2, "StartTimer1"
 End If
End Sub

Sub Barcodes()
Application.ScreenUpdating = False
Sheets("Codes").Select

Range("A3:A400").ClearContents
Range("C3:c400").ClearContents
Range("C3:c400").ClearComments
Sheets("Huidig bestand").Select
Workbooks.Open Filename:="G:\Planning\" & Format(Date, "yyyy") & "\" & Range("D6").Value & "\" & Range("B10").Value
Opvragen_barcodes
t = DateAdd("S", 900, Time)
 Blad3.Range("C2").Value = Format(900, "00:00:00")
 Range("A2:C2").Select
    With Selection
        .VerticalAlignment = xlCenter
        .Interior.PatternColorIndex = xlAutomatic
        .Interior.Color = 5296274
        .Interior.TintAndShade = 0
        .Interior.PatternTintAndShade = 0
    End With
 Application.OnTime t, "Barcodes"
   StartTimer1
 DoEvents
Application.ScreenUpdating = True
End Sub

Sub Opvragen_barcodes()

On Error Resume Next

Sheets(Format(Date, "ddd") & IIf(Format(Now, "hh:mm") < "14:00", " VM + Dag", " NM")).Select

For Each cl In Range("C20:C400")
If Left(cl, 2) = 99 Or Left(cl, 2) = 10 And cl.Offset(0, 6) = "RE" Then 'And Left(cl.Offset(0, 1), 2) = "LK" And cl.Offset(0, 6) = "RE" Then

cl.Copy Destination:=ThisWorkbook.Sheets("Codes").Range("A500").End(xlUp).Offset(1, 0)
cl.Offset(0, 1).Copy Destination:=ThisWorkbook.Sheets("Codes").Range("C500").End(xlUp).Offset(1, 0)

End If
Next

ActiveWorkbook.Close SaveChanges:=False

Sheets("Codes").Select
Range("A3:C51").Borders.LineStyle = xlContinuous
Range("A1").Select

End Sub

 

[HSV]

 Blad3.Range("C2") = TimeValue("00:15:00")