UserForm Date Difference with Live Countdown

K

kwooden

New Member
Joined
May 5, 2021
Messages
11
Office Version
  1. 365
Platform
  1. Windows
Hello,

I'm trying to populate a textbox with a live countdown based on the difference between two dates. I have the following textboxes:

Textbox1: formatted with Now()
Textbox2: Static date (12 Sep 23)
Textbox3: I want a running countdown that give me the remaining days, hours, minutes, and seconds

I found a VBA code; however, it only gives me a strange date and the hh:mm:ss plus it crashes my form and freezes excel. This is what I have:


Private Sub UserForm_Activate()

Dim remTime As Date
While True
remTime = DateValue("12 Sep 2023") + TimeValue("00:00:00") - Now
Me.Label1 = Int(remTime) & " Days " & Format(remTime - Int(remTime), "D HH:MM:SS")
Me.Repaint
Application.Wait Now + #12:00:01 AM#
Wend

End Sub
 

Attachments

  • Screenshot 2023-06-24 091137.jpg
    Screenshot 2023-06-24 091137.jpg
    13.4 KB · Views: 10

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
Sort by date Sort by votes
Hi kwooden

Here is a workbook demo:
Countdown.xlsm






1- In a Standard Module:
VBA Code: 
Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

#If VBA7 Then
    Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
    Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
#End If

Private oTB1 As MsForms.TextBox, oTB2 As MsForms.TextBox, oLbl As MsForms.Label


Public Sub StartCountDown( _
    ByVal oTextBox1 As MsForms.TextBox, _
    ByVal oTextBox2 As MsForms.TextBox, _
    ByVal oLabel As MsForms.Label _
)

    If Not IsDate(oTextBox1) Or Not IsDate(oTextBox2) Then
        Call KillTimer(Application.hwnd, NULL_PTR)
        MsgBox "Error!!" & vbNewLine & "Both TextBox1 and TextBox2 must contain valid dates."
        Exit Sub
    End If

    Set oTB1 = oTextBox1
    Set oTB2 = oTextBox2
    Set oLbl = oLabel
    
    Call CountDownProc
    Call KillTimer(Application.hwnd, NULL_PTR)
    Call SetTimer(Application.hwnd, NULL_PTR, 1000&, AddressOf CountDownProc)

End Sub

Public Sub StopCountDown()
    Call KillTimer(Application.hwnd, NULL_PTR)
End Sub

Private Sub CountDownProc()

    Dim dDDiffSecs As Double, dDays As Double, dHrs As Double, dMins As Double, dSecs As Double
    Dim sSp As String
    
    If Not IsDate(oTB1) Or Not IsDate(oTB2) Then
        oLbl = "error": Exit Sub
    End If
    
    oTB1 = Now
    
    dDDiffSecs = DateDiff("s", oTB1, oTB2)
    dDays = dDDiffSecs / 60 / 60 \ 24
    dHrs = dDDiffSecs / 60 \ 60 - (dDays * 24)
    dMins = dDDiffSecs \ 60 - (dHrs * 60) - (dDays * 60 * 24)
    dSecs = dDDiffSecs - (dMins * 60) - (dHrs * 60 * 60) - (dDays * 60 * 60 * 24)
    
    oLbl = vbNewLine & "Remaining Time:" & vbNewLine & vbNewLine
    sSp = Space(5&)
    oLbl = oLbl & (dDays) & " Days" & sSp & (dHrs) & " Hours" & sSp & (dMins) & " Mins" & sSp & (dSecs) & " Secs"
    oLbl.Parent.Repaint

End Sub



2- In the UserForm Module:
VBA Code: 
Option Explicit

Private Sub UserForm_Initialize()
    Caption = "CountDown"
    TextBox1 = Now
    TextBox2 = "12 Sep 23"
    Label1.Caption = ""
    Call StartCountDown(TextBox1, TextBox2, Label1)
End Sub

Private Sub UserForm_Terminate()
    Call StopCountDown
End Sub
 
Upvote 0
Jaafar Tribak said:
Hi kwooden

Here is a workbook demo:
Countdown.xlsm






1- In a Standard Module:
VBA Code: 
Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

#If VBA7 Then
    Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
    Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
#End If

Private oTB1 As MsForms.TextBox, oTB2 As MsForms.TextBox, oLbl As MsForms.Label


Public Sub StartCountDown( _
    ByVal oTextBox1 As MsForms.TextBox, _
    ByVal oTextBox2 As MsForms.TextBox, _
    ByVal oLabel As MsForms.Label _
)

    If Not IsDate(oTextBox1) Or Not IsDate(oTextBox2) Then
        Call KillTimer(Application.hwnd, NULL_PTR)
        MsgBox "Error!!" & vbNewLine & "Both TextBox1 and TextBox2 must contain valid dates."
        Exit Sub
    End If

    Set oTB1 = oTextBox1
    Set oTB2 = oTextBox2
    Set oLbl = oLabel
   
    Call CountDownProc
    Call KillTimer(Application.hwnd, NULL_PTR)
    Call SetTimer(Application.hwnd, NULL_PTR, 1000&, AddressOf CountDownProc)

End Sub

Public Sub StopCountDown()
    Call KillTimer(Application.hwnd, NULL_PTR)
End Sub

Private Sub CountDownProc()

    Dim dDDiffSecs As Double, dDays As Double, dHrs As Double, dMins As Double, dSecs As Double
    Dim sSp As String
   
    If Not IsDate(oTB1) Or Not IsDate(oTB2) Then
        oLbl = "error": Exit Sub
    End If
   
    oTB1 = Now
   
    dDDiffSecs = DateDiff("s", oTB1, oTB2)
    dDays = dDDiffSecs / 60 / 60 \ 24
    dHrs = dDDiffSecs / 60 \ 60 - (dDays * 24)
    dMins = dDDiffSecs \ 60 - (dHrs * 60) - (dDays * 60 * 24)
    dSecs = dDDiffSecs - (dMins * 60) - (dHrs * 60 * 60) - (dDays * 60 * 60 * 24)
   
    oLbl = vbNewLine & "Remaining Time:" & vbNewLine & vbNewLine
    sSp = Space(5&)
    oLbl = oLbl & (dDays) & " Days" & sSp & (dHrs) & " Hours" & sSp & (dMins) & " Mins" & sSp & (dSecs) & " Secs"
    oLbl.Parent.Repaint

End Sub



2- In the UserForm Module:
VBA Code: 
Option Explicit

Private Sub UserForm_Initialize()
    Caption = "CountDown"
    TextBox1 = Now
    TextBox2 = "12 Sep 23"
    Label1.Caption = ""
    Call StartCountDown(TextBox1, TextBox2, Label1)
End Sub

Private Sub UserForm_Terminate()
    Call StopCountDown
End Sub
Click to expand...

Jaafar Tribak,​


Thank you for your reply and solution. I'm not sure what to do with the code above the yellow highlight. I was able to put the remainder into modules, but this code did not create a module. Also, I tried to download the file but could not open it in excel.
 

Attachments

  • Countdown Screenshot.jpg
    Countdown Screenshot.jpg
    171.9 KB · Views: 8
Upvote 0
kwooden said:

Jaafar Tribak,​


Thank you for your reply and solution. I'm not sure what to do with the code above the yellow highlight. I was able to put the remainder into modules, but this code did not create a module. Also, I tried to download the file but could not open it in excel.
Click to expand...
1- Add a new standard\normal module to your project and place in it the entire first code.
2- Add the second code to the UserForm module.

Also, I tried to download the file but could not open it in excel.
Click to expand...
The file in the link is downloadable and working. You must be doing something wrong.


Edit: You may need to unblock the file after you download it to your computer.
Right click on the file from explorer and unblock it as shown in the image below :

Untitfffffffffffffled.png
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Countdown with vba
Replies
2
Views
427
asyamonique
A
K
  • Question Question
Help with difference between 2 dates including am/pm and check multiple entries to see if they occur at the same date and am/pm
Replies
1
Views
514
XLfriend777
XLfriend777
V
  • Question Question
Date Change
2 3
Replies
21
Views
1K
MARK858
MARK858
A
  • Question Question
Find the difference in days, hours and minutes between two dates and times
Replies
5
Views
1K
Dave Patton
D
MrDB4Excel
  • Question Question
If Find Blank Cell
Replies
0
Views
694
MrDB4Excel
MrDB4Excel

Forum statistics

Threads
1,223,884
Messages
6,175,173
Members
452,615
Latest member
bogeys2birdies

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top