Re: Calculating a time and date (counting down)

Tech Tip: Click here to run a free scan for Windows Errors and optimize PC performance

Steve Gerrard wrote:
Rick Rothstein (MVP - VB) wrote:

Another slight bug. Blame this on Bobzter100 :)

It reports that March 20, 2008 is 1 month, 4 weeks, 2 days away.


A new version, which I think avoids the bugs.

' the demo

Dim When As Date

Private Sub Form_Load()
When = DateAdd("d", 1, DateAdd("m", 2, Date)) _
+ TimeSerial(Hour(Now), Minute(Now) + 2, 0)
Me.Caption = When
End Sub

Private Sub Timer1_Timer()
Label1.Caption = YMWDHMS(When)
End Sub

' the functions

Function YMWDHMS(ByVal Target As Date) As String
Dim Ref As Date
Dim Secs As Long
Dim Mins As Long
Dim Hrs As Long
Dim Days As Long
Dim Weeks As Long
Dim Months As Long
Dim Years As Long

Ref = Now
If Ref > Target Then
Ref = Target
Target = Now
End If

Secs = DateDiff("s", Ref, Target)
Mins = Secs \ 60: Secs = Secs - Mins * 60
Hrs = Mins \ 60: Mins = Mins - Hrs * 60
Days = Hrs \ 24: Hrs = Hrs - Days * 24

Ref = Fix(Ref)
Target = DateAdd("d", Days, Ref)

Months = DateDiff("m", Ref, Target)
Years = Months \ 12: Months = Months - Years * 12
Ref = DateAdd("m", Months, DateAdd("yyyy", Years, Ref))
Days = DateDiff("d", Ref, Target)
Weeks = Days \ 7: Days = Days - Weeks * 7

YMWDHMS = FormatUnit(Years, "year") & ", " _
& FormatUnit(Months, "month") & ", " _
& FormatUnit(Weeks, "week") & ", " _
& FormatUnit(Days, "day") & ", " _
& FormatUnit(Hrs, "hour") & ", " _
& FormatUnit(Mins, "minute") & ", " _
& FormatUnit(Secs, "second")
End Function

Private Function FormatUnit(Num As Long, Unit As String) As String
FormatUnit = CStr(Num) & " " & Unit & IIf(Num = 1, "", "s")
End Function


.

Relevant Pages

  • Re: Range with "Large"
    ... Private Sub Worksheet_SelectionChange(ByVal Target As Range) ... Dim myRange ...
    (microsoft.public.excel.programming)
  • Re: Conditional Formatting
    ... Dim Values As Variant ... For Each cell In Values ... Private Sub Worksheet_Change(ByVal Target As Range) to the following which will ...
    (microsoft.public.excel.worksheet.functions)
  • RE: PUTTING VBAS TOGETHER
    ... Private Sub Worksheet_Change(ByVal Target As Range) ... Dim cWdth As Single, MrgeWdth As Single ...
    (microsoft.public.excel.worksheet.functions)
  • RE: PUTTING VBAS TOGETHER
    ... Private Sub Worksheet_Change(ByVal Target As Range) ... Dim cWdth As Single, MrgeWdth As Single ...
    (microsoft.public.excel.worksheet.functions)
  • Re: Using a named range in the Worksheet_Change event
    ... The Target variable is returning the cell which has been changed, so we test if Target is intersecting with G9:G15. ... Private Sub Worksheet_Change ... Dim isect As Variant ... The user will be entering data in cells g9..15, ...
    (microsoft.public.excel.programming)