Nedtællngsur

jeg har tidligere fået hjælp til et program, hvor¨jeg laver en måling hver sekund i ca 200 sec. Programmet sørger for at data kommer ind hver sekund, hvorefter data overføres til et nyt ark, når målingen er færdig.
Jeg har nu brug for, at jeg samtidig med at målingen kører, på skærmen i et felt kan se hvor lang tid der er gået.
Der skal sættes en programkode ind, som medfører at jeg i f.eks F1 hele tiden kan se hvor mange sekunder er tilbage af min måling
Nedenfor ses mit visual basic program:

Public RunWhen As Double
Public cRunIntervalSeconds  ' one minutes
Public Const cRunWhat = "TheSub"
Public i As Long


Sub Pico()
If i = 0 Then
cRunIntervalSeconds = 4
ElseIf i >= 1 And i < 196 Then
cRunIntervalSeconds = 1
Else
cRunIntervalSeconds = 1
End If
RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, _
    schedule:=True
End Sub

Sub TheSub()
If i = 0 Then
Sheets("Ark1").Columns("A:A").ClearContents
End If
  i = i + 1
  If i > 196 Then
      Call StopTimer
      Call Flyt
      MsgBox "Kopiering slut & data overført"
      Exit Sub
  End If
Sheets("Ark1").Range("A" & i) = Sheets("Ark1").Range("D1") ' Navn på hovedark
  Call Pico
End Sub

Sub StopTimer()
i = 0
  On Error Resume Next
  Application.OnTime earliesttime:=RunWhen, _
      procedure:=cRunWhat, schedule:=False
End Sub
Public Sub Flyt()
' ret arknavnet til dit ark
If Sheets("Ark2").Range("A1") = "" Then
A = 1
ElseIf Sheets("Ark2").Range("B1") = "" Then
A = 2
Else
A = Sheets("Ark2").Range("A1").End(xlToRight).Offset(0, 1).Column
End If
Sheets("Ark2").Cells(1, A) = Now()
For pp = 2 To 197
Sheets("Ark2").Cells(pp, A) = Sheets("Ark1").Range("A" & pp - 1).Value
Next

'kopierer N1, N2, N3, P1, P2, P3 fra ark(Sekant)


X = 1
For pp = 200 To 210
Sheets("Ark2").Cells(pp, A) = Sheets("start").Range("C" & X).Value
X = X + 1
Next


End Sub