Excel : Displaying a Count Down 1

[shytott]

Hi All

Is there anyway of displaying a continually decrementing count down to a given future date ie that when you open the spreadsheet it will say eg. 2 months 14 days 10 hrs 3secs to Christmas Day.

Thanking you

 

[000Steve000]

="25/12/04 00:01"-NOW() in a cell returns 139.18 (cell formatted to number) This equates to 139.18 days to 1 minute past midnight on Xmas day. Formatting the cell (or another cell with same formula) to (custom) hh:mm:ss returns 04:24:03 (the 0.18 converted to hours minutes and seconds). I think finding the number of months is more demanding. You can return a month figure using the MONTH function but the number of months 'til Xmas would depend on whether we are past the 25th of this month. Number of weeks is easier ie 139/7! Hope this gets you thinking.

 

[HRick]

Here is kind of long way to extract the info you want

A B

2 Day/Current
Month Calc =IF(OR(A5=4,A5=6,A5=9,A5=11),30,
IF(A5=2,28,31))

4 =YEAR(NOW()) =YEAR(B12)
5 =MONTH(NOW()) =MONTH(B12)
6 =DAY(NOW()) =DAY(B12)
7 =HOUR(NOW()) =HOUR(B12)
8 =MINUTE(NOW()) =MINUTE(B12)
9 =SECOND(NOW()) =SECOND(B12)


12 Future Date 04/16/2006:14:25:36
13 year =IF(A5>B5,B4-A4-1,B4-A4)
14 months =IF(A6>B6,IF(A5>B5,12-A5+B5-1,B5-A5
-1),IF(A5>B5,12-A5+B5,B5-A5))
15 days =IF(A7>B7,IF(A6>B6,B2-A6+B6-1,B6-A6
-1),IF(A6>B6,B2-A6+B6,B6-A6))
16 hours =IF(A8>B8,IF(A7>B7,24-A7+B7-1,B7-A7
-1),IF(A7>B7,24-A7+B7,B7-A7))
17 minutes =IF(A9>B9,IF(A8>B8,60-A8+B8-1,B8-A8
-1),IF(A8>B8,60-A8+B8,B8-A8))
18 seconds =IF(A9>B9,60-A9+B9,B9-A9)

Notes:
1. Formulas in rows 2 thru 9 can be anywhere or hidden
2. Future date (B12) is formatted dd/mm/yyyy:hh/mm/ss
3. As an alternate, each component of future date
could be entered directly into cells (B4) thru (B9)
4. This may need some tweaking for leapyear.

 

[shytott]

Thanks Chaps
I've got to more oe less the same stage, but what you end up with is a static display of the current hrs:mins:secs and it only updates when you hit F9. So basically, is there a way to continually update the screen.

Thanks for your suggestions.

 

[000Steve000]

You could have a macro running constantly in the background that recalculates every second.It soumds very heavy on system resourses.

 

[byundt]

Here is a macro running constantly in the background to put a countdown timer in cell A1 of the first worksheet. It displays the months, days, hours, minutes and seconds until midnight on Christmas Day. The macro starts when the workbook is opened and doesn't stop until you close it. The countdown will update every second.

'This code goes in the ThisWorkbook code pane
Sub Auto_Open()
TimeToChristmas
End Sub

Sub Auto_Close()
StopTimer
End Sub

'This code goes in a regular module sheet
Public RunTime As Double

Sub TimeToChristmas()
Static lngYear As Long, months As Long, days As Long
Dim hours As Long, minutes As Long, seconds As Long
Static xmas As Double
Dim str As String
If lngYear = 0 Then
    lngYear = Year(Date)
    xmas = DateSerial(lngYear, 12, 25)
    If xmas < Date Then xmas = DateSerial(lngYear + 1, 12, 25)
    months = DateDiff("m", Date, xmas)
    days = Int(xmas - DateSerial(lngYear, Month(Date) + months, Day(Date))) - 1
End If
hours = Int(24 * (1 - Time))
minutes = Int(59 - Minute(Now))
seconds = Int(60 - Second(Now))

'Build the time string
str = months & " month"
If months > 1 Then str = str & "s"
str = str & ", " & days & " day"
If days > 1 Then str = str & "s"
str = str & ", " & hours & " hour"
If hours > 1 Then str = str & "s"
str = str & ", " & minutes & " minute"
If minutes > 1 Then str = str & "s"
str = str & ", " & seconds & " second"
If seconds > 1 Then str = str & "s"

Sheets(1).Range("A1") = str
RunTime = Now + TimeValue("00:00:01")
Application.OnTime earliesttime:=RunTime, procedure:="TimeToChristmas"

End Sub

Sub StopTimer()
On Error Resume Next
Application.OnTime earliesttime:=RunTime, procedure:="TimeToChrismas", schedule:=False
End Sub

Note that part of the code goes in the ThisWorkbook code pane and the balance goes in a regular module sheet.

 

[shytott]

Thanks very Much byundt. Sorry about the delay in repsonding - been on holiday! I've tried your routine split bewteen'This workbook' and a new standard module but it doesnt seem to want to work. Is there anything that actually invokes the routine?

Cheers Shytott

 

[byundt]

Shytott,
I just tested the posted code in Excel 2003 and Excel 97--and it put the countdown timer in the first worksheet, cell A1. I launched the code by running the ThisWorkbook!Workbook_Open macro. You can also launch by running the TimeToChristmas macro.

I'll admit there is a problem getting the timer to stop. The only reliable means I've found is turning Excel off.
Brad

 

[byundt]

Shytott,
I have figured out how to turn the timer off. It's a little different from the sample code offered by Chip Pearson, but works quite well:

'This code goes in the ThisWorkbook code pane
Sub Auto_Open()
RunXmasTimer = True
TimeToChristmas
End Sub

Sub Auto_Close()
StopTimer
End Sub

'This code goes in a regular module sheet
Public RunTime As Double
Public RunXmasTimer As Boolean

Sub TimeToChristmas()
Static lngYear As Long, months As Long, days As Long
Dim hours As Long, minutes As Long, seconds As Long
Static xmas As Double
Dim str As String
If lngYear = 0 Then
    lngYear = Year(Date)
    xmas = DateSerial(lngYear, 12, 25)
    If xmas < Date Then xmas = DateSerial(lngYear + 1, 12, 25)
    months = DateDiff("m", Date, xmas)
    days = Int(xmas - DateSerial(lngYear, Month(Date) + months, Day(Date))) - 1
End If
hours = Int(24 * (1 - Time))
minutes = Int(59 - Minute(Now))
seconds = Int(60 - Second(Now))

'Build the time string
str = months & " month"
If months > 1 Then str = str & "s"
str = str & ", " & days & " day"
If days > 1 Then str = str & "s"
str = str & ", " & hours & " hour"
If hours > 1 Then str = str & "s"
str = str & ", " & minutes & " minute"
If minutes > 1 Then str = str & "s"
str = str & ", " & seconds & " second"
If seconds > 1 Then str = str & "s"

Sheets(1).Range("A1") = str
RunTime = Now + TimeValue("00:00:01")
If RunXmasTimer Then _
    Application.OnTime earliesttime:=RunTime, procedure:="TimeToChristmas"

End Sub

Sub StopTimer()
RunXmasTimer = False
End Sub

Brad

 

[byundt]

One final point: you can only start the revised timer by opening the workbook or by running the ThisWorkbook!Workbook_Open sub from the Tools...Macro...Macros menu item.

You stop the timer either by running the StopTimer sub or by closing the workbook.

 

[shytott]

Brad

Just a quick note to say thankyou. I did a couple of tweaks - namely changed the date - Xmas was just any old date - the actual date was June 1 2005! but i think i've cracked how to chage it (although it does return the day count short by 1). I'll have a further ponder!

Thanks for your help - much appreciated.

 

[byundt]

shytott,
I don't think the code was working very well for June 1--because it was calculating negative days in a month. Christmas worked OK, but the previous code failed if the target day was before the current day.

Just for grins, I also added the capability of specifying a target time in addition to the date. In the sample code below, it is 9 AM on Christmas day.

Finally, I changed the subs so all the code can go in the ThisWorkbook code pane. It should launch when the workbookopens (or when you run the ThisWorkbook.Workbook_Open sub). It will stop when you close the workbook (or run the ThisWorkbook.Workbook_BeforeClose sub).

'This code goes in the ThisWorkbook code pane
Public RunTime As Date
Public RunXmasTimer As Boolean

Sub workbook_open()
RunXmasTimer = True
ThisWorkbook.TimeToChristmas
End Sub

Sub workbook_beforeclose(Cancel As Boolean)
StopTimer
End Sub

Sub TimeToChristmas()
'Puts a countdown timer in cell A1 of the first worksheet in this workbook
Static lngYear As Long, Y As Long, months As Long, days As Long
Dim hours As Long, minutes As Long, seconds As Long
Static xmas As Date, Date1 As Date, temp1 As Date, tempus As Date, tyme As Date
Dim str As String
tyme = Time
If lngYear = 0 Then
    Date1 = Date
    lngYear = Year(Date1)
    xmas = DateSerial(lngYear, 12, 25) + TimeValue("9:00:00")
    If xmas < Date1 Then xmas = DateSerial(lngYear + 1, 12, 25)
    temp1 = DateSerial(Year(xmas), Month(Date1), Day(Date1))
    Y = Year(xmas) - Year(Date1) + (temp1 > xmas)
    months = Month(xmas) - Month(Date1) - (12 * (temp1 > xmas))
    days = Day(xmas) - Day(Date1)
    If days < 0 Then
        months = months - 1
        days = Day(DateSerial(Year(xmas), Month(xmas), 0)) + days
    End If
    If xmas - Int(xmas) < tyme Then days = days - 1
End If
tempus = xmas - Int(xmas) - tyme
If tempus < 0 Then tempus = tempus + 1
hours = Int(24 * tempus)
minutes = Int(tempus * 1440 - hours * 60)
seconds = Int(tempus * 86400 - hours * 3600 - minutes * 60)

'Build the time string
If Y > 0 Then str = Y & " year"
If Y > 1 Then str = str & "s"
str = months & " month"
If months > 1 Then str = str & "s"
str = str & ", " & days & " day"
If days > 1 Then str = str & "s"
str = str & ", " & hours & " hour"
If hours > 1 Then str = str & "s"
str = str & ", " & minutes & " minute"
If minutes > 1 Then str = str & "s"
str = str & ", " & seconds & " second"
If seconds > 1 Then str = str & "s"

Sheets(1).Range("A1") = str
RunTime = Now + TimeValue("00:00:01")
If RunXmasTimer Then _
    Application.OnTime earliesttime:=RunTime, procedure:="ThisWorkbook.TimeToChristmas"
End Sub

Sub StopTimer()
RunXmasTimer = False
End Sub

Brad