エクセルVBA 時間のカウントダウン

エクセルを起動後、A1セルに10分のカウントダウンタイマーを「分：秒」で表示する方法（VBA）をご教示頂けないでしょうか。
よろしくお願い致します。

No.1 ベストアンサー 回答者： cj_mover 回答日時： 2013/10/18 22:52

１レスです。

きっと、もっとずっと簡単に出来るとお考えなのでしょう。
例えば、ユーザーがどこかのセルを編集状態にしたらば、
どうやっても、カウントダウンを進める（VBAからセル値を変える）ことは出来ません。
そういう理由から、ユーザーフォームに表示させるのが一般的ではあります。
何故、セルに表示させたいのでしょう？
10分の間、ExcelやVBAは何もしないのでしょうか？
途中でカウントダウンを止めたり、ブックを閉じたりすることはあるでしょうか？
そもそも何故カウントダウンが必要なのでしょう？
等々、疑問は多数湧いてくるものの、すべてに応える体力はありません。

経験してみないと、こちらが何を言っているのかも解らないと思います。
一応、書かれたオーダーには応えています。
中でも無難な（トラブルの少ない）手法を選んだつもりです。
ただ、これが（仕様的に）実際に役に立つのかどうかは、ご本人にしか判りません。
これはあくまでテスト用サンプルです。
テストしてみて求める仕様との違いを確かめながら、仕様をはっきりさせて、
改めて、全体を見通して設計を見直してみてください。
若しくは、目的、用途、条件、といったことを十分に文章化した上で、
あらたに相談するとか、質問を建て直した方が、解決は近いと思います。

ご使用の環境が書かれていませんので、念の為、標準モジュールの記述は
Excel　32ビット版・64ビット版、両方、別々に書いておきました。
どちらかを正しく選ばないとコンパイルエラーになります。
ThisWorkbookモジュールの記述は共通です。


' ' 〓〓〓〓〓〓〓〓標準モジュール・32ビット版〓〓〓〓〓〓〓〓
Option Explicit

Public flgStopTimer As Boolean

Private Declare Function SetTimer Lib "user32" _
　　　　　　　　　　　　(ByVal hwnd As Long, ByVal nIDEvent As Long, _
　　　　　　　　　　　　ByVal uElapse As Long, ByVal lpTimerFunc As Long) _
　　　　　　　　　　　　As Long
Private Declare Sub KillTimer Lib "user32" _
　　　　　　　　　　　　(ByVal hwnd As Long, ByVal nIDEvent As Long)

Private oTargetRange As Range
Private dtTargetTime As Date
Private nTimerIdx As Long

Private Const dtTimeSpan As Date = #12:10:00 AM#　　 '　　１０分後
Private Const nIntervalMilliSecond As Long = 1000&　　'　　１秒間隔

Sub TestCountDown()
　　Call StartCountDown
End Sub

Private Sub StartCountDown()
　　dtTargetTime = Now + dtTimeSpan
　　Set oTargetRange = Sheets("Sheet1").Cells(1, "A")
　　oTargetRange.Value = dtTimeSpan
　　oTargetRange.NumberFormat = "mm:ss"
'　　With Cells(2, "A")
'　　　　.Value = dtTargetTime
'　　　　.NumberFormat = "h:mm:ss"
'　　End With
　　nTimerIdx = SetTimer(0&, 0&, nIntervalMilliSecond, AddressOf RcvEvent)
End Sub

Private Sub RcvEvent(ByVal hwnd As Long, ByVal uMsg As Long, _
　　　　　　　　　　ByVal idEvent As Long, ByVal dwTime As Long)
　　If Now > dtTargetTime Or flgStopTimer Then
　　　　KillTimer 0&, idEvent
　　　　nTimerIdx = 0&
　　　　Set oTargetRange = Nothing
　　Else
　　　　On Error Resume Next
　　　　oTargetRange.Value = dtTargetTime - Now
　　　　On Error GoTo 0
　　　　DoEvents
　　End If
End Sub

Private Sub StopCountDown()
　　KillTimer 0&, nTimerIdx
　　nTimerIdx = 0&
　　Set oTargetRange = Nothing
End Sub

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

' ' 〓〓〓〓〓〓〓〓標準モジュール・64ビット版〓〓〓〓〓〓〓〓
Option Explicit

Public flgStopTimer As Boolean

Private Declare PtrSafe Function SetTimer Lib "user32" _
　　　　　　　　　　　　(ByVal hwnd As Long, ByVal nIDEvent As LongPtr, _
　　　　　　　　　　　　ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) _
　　　　　　　　　　　　As LongPtr
Private Declare PtrSafe Sub KillTimer Lib "user32" _
　　　　　　　　　　　　(ByVal hwnd As Long, ByVal nIDEvent As LongPtr)

Private oTargetRange As Range
Private dtTargetTime As Date
Private nTimerIdx As LongPtr

Private Const dtTimeSpan As Date = #12:10:00 AM#　　 '　　１０分後
Private Const nIntervalMilliSecond As Long = 1000&　　'　　１秒間隔

Sub TestCountDown()
　　Call StartCountDown
End Sub

Private Sub StartCountDown()
　　dtTargetTime = Now + dtTimeSpan
　　Set oTargetRange = Sheets("Sheet1").Cells(1, "A")
　　oTargetRange.Value = dtTimeSpan
　　oTargetRange.NumberFormat = "mm:ss"
'　　With Cells(2, "A")
'　　　　.Value = dtTargetTime
'　　　　.NumberFormat = "h:mm:ss"
'　　End With
　　nTimerIdx = SetTimer(0&, 0^, nIntervalMilliSecond, AddressOf RcvEvent)
End Sub

Private Sub RcvEvent(ByVal hwnd As Long, ByVal uMsg As Long, _
　　　　　　　　　　ByVal idEvent As LongPtr, ByVal dwTime As Long)
　　If Now > dtTargetTime Or flgStopTimer Then
　　　　KillTimer 0&, idEvent
　　　　nTimerIdx = 0^
　　　　Set oTargetRange = Nothing
　　Else
　　　　On Error Resume Next
　　　　oTargetRange.Value = dtTargetTime - Now
　　　　On Error GoTo 0
　　　　DoEvents
　　End If
End Sub

Private Sub StopCountDown()
　　KillTimer 0&, nTimerIdx
　　nTimerIdx = 0^
　　Set oTargetRange = Nothing
End Sub

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

' ' 〓〓〓〓〓〓〓ThisWorkbookモジュール　共通版〓〓〓〓〓〓〓

Private Sub Workbook_BeforeClose(Cancel As Boolean)
　　Application.Run "StopCountDown"
End Sub

Private Sub Workbook_Open()
　　Application.OnTime Now, "StartCountDown"
End Sub

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

この回答へのお礼

御礼が遅くなりました。私はVBAは全く分からないのですが、安易な質問で大変な労力をおかけしました。
しかし、お蔭様で頂いた方法で初期の目的を達することができました。有難うございました。
ご指摘の通り、安易にできると考えておりましたので、今後は質問のし方も考えたいと思います。拝

お礼日時：2013/10/21 14:28