Problème avec un compte à rebours

Option Explicit
Private HeureFin As Date, HeureOnTime As Date

Sub Compter()
If HeureOnTime = 0 Then
  HeureFin = Now + Feuil1.[D3].Value
  Feuil1.[D3].Font.ColorIndex = 3
ElseIf Now >= HeureFin Then
  Beep
  Exit Sub
Else
  Feuil1.[D3].Value = HeureFin - Now
  End If
HeureOnTime = Now + TimeSerial(0, 0, 1)
Application.OnTime HeureOnTime, "Compter"
End Sub
Sub Suspendre()
If HeureOnTime = 0 Then Exit Sub
Application.OnTime HeureOnTime, "Compter", Schedule:=False
HeureOnTime = 0
End Sub
Sub Arrêter()
Suspendre
Feuil1.[D3].Font.ColorIndex = 34
Feuil1.[D3].Value = 0
End Sub
'

Sub Choix()
ChoixDurée.Show ' Y lancer Compter au lieu de CountUp
End Sub