Countdown zum Renteneintritt

[Paul1206]

Hallo Miteinander,

gestern beim Grillen kam die Idee für meinem Nachbar etwas zusammenzustellen, um die noch verbleibenden Tage, Stunden etc. anzeigen zu lassen.
Das ist nun das Ergebnis zu diesem Problem. Es ist eher als lustige Möglichkeit zu betrachten, was sich so alles mit VBA in Excel anstellen lässt.

Gruß Uwe

[thowe]

Hallo Paul,

danke für diese nette Spielerei...
Ob ich verzückt bin bei den Tausenden Tage, die mir dein Tool so anzeigt... ?

Ich bin noch nicht dazugekommen, den code zu lesen, aber ich bin davon überzeugt, einiges für mich mitnehmen zu können, lg

[Paul1206]

Hallo thowe,

naja ist eigentlich Allerweltscode verbunden mit ein bisschen Datums- und Zeitrechnerei.

Gruß Uwe

[d'r Bastler]

Moin Uwe, moin towe,

was für Folgen so eine Grillparty doch haben kann ...

Ich habe auch ein wenig gebastelt und biete folgende Spielerei an: Ein Mini-Code in einem Sheet ...

Code: Alles auswählen

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True

If IsDate(Target) Then
    If isRunning = False Then
        StartCountDown
    Else
        isRunning = False
    End If
End If

End Sub

... und ein bisschen mehr in einem Modul:

Code: Alles auswählen

Option Explicit
Public isRunning As Boolean

Sub StartCountDown()
Dim dEnd As Date, dNow As Date, iDays As Integer, sHours As String, sMins As String, sSecs As String
Dim sgShow As Single, sgDelay As Single

isRunning = True

On Error Resume Next
dEnd = ActiveCell

dNow = Now()
Do Until dNow >= dEnd
sgDelay = 0.1 '= 1 sekunde
sgShow = Timer + sgDelay
    Do While Timer < sgShow
    DoEvents
        If isRunning = False Then
            Application.StatusBar = False
            Exit Sub
        End If
        iDays = DateDiff("d", dNow, dEnd) - 1
        sHours = 24 - Hour(Now) - 1
            If sHours < 10 Then
            sHours = "0" & sHours
        End If
        
        sMins = 60 - Minute(Now) - 1
        If sMins < 10 Then
            sMins = "0" & sMins
        End If
        sSecs = 60 - Second(Now) - 1
        
        If sSecs < 10 Then
            sSecs = "0" & sSecs
        End If
    Application.StatusBar = _
        "Bis zum " & dEnd & " sind es: " & iDays & " Tage & " & sHours & " : " & sMins & " : " & sSecs & " Carpe Diem"
   Loop
Loop

End Sub

... und schon kann man durch Doppelklick auf ein beliebiges Datum im Sheet einen CountDown auslösen, der sich dann dezent in der Statuszeile zeigt. Ein Doppelklick auf ein anderes Datum stoppt erst den laufenden und wartet dann auf den nächsten Auftrag.

Eben getestet: Läuft auch auf MacOS!

Aus dieser Spielerei ließ sich auch leicht eine Eieruhr basteln

Grüße und ich hätte mein Steak bitte medium-rare

[d'r Bastler]

Moin allerseits,

kleine Ergänzung zu oben:
während der CountDown läuft lässt sich der VBA-Code nicht bearbeiten. Aber ein Aufruf anderer Makros klappt durchaus. Getestet mit (ins Modul)

Code: Alles auswählen

Sub test()
Dim i As Integer
    i = WorksheetFunction.CountA(ActiveSheet.UsedRange)
    MsgBox i
End Sub

... und ein bisschen Salat bitte