Excelのストップウォッチについて

ExcelのVBAを利用して、ストップウォッチ機能をつけたいと思っております。
現在別の方で作っていただいたのが以下になります。
①ストップウォッチのボタンを押したら、ストップウォッチ画面が表示される。
②表示された画面のスタートをクリックしたら画面に表示されるカウントがスタートされ、
スタートボタンもストップに変更される
③カウント中にストップを押したらスタートボタンに変更され、ストップウォッチの時間がコピーされ、I列の一番下が選択される
④再度スタートをクリックすると②～③が繰り返し行われる
⑤閉じるのマークをクリックするとストップウォッチ画面が消えるというところまではできています。

これを以下の2つの機能を追加したいと思っています。
②スタートをクリックしたときに、C6セルに”〇”を記入、D6セルにもともと入っている数字+1をし、
カウントアップがスタートし、スタートボタンもストップに変わる
③ストップを押したときに、カウントした時間をR1へ記載する。もしR1がすでに入力されているならR2へ、R1もR2も記載されていたらR3へ記載・・・をR５まで行う

今作っているのが以下のVBAになります。
Sub stopWatch(Form)
On Error GoTo ending
Dim dblTimer As Double, CB As New DataObject
If blnStart = True Then
With Form
.StartStopB.Caption = "START"
.StartStopB.BackColor = &H8000000D
End With
blnStop = True
Exit Sub
End If
blnStart = True
blnStop = False
dblTimer = Timer
With Form
.StartStopB.Caption = "STOP"
.StartStopB.BackColor = &HC0&
End With

Do Until blnStop = True
Form.TimeText.Value = TimeValue(CStr(CDate(Int((Timer - dblTimer)) / 86400#)))
DoEvents
If blnStop = True Then Exit Do
Loop
blnStart = False
blnStop = False

'クリップボードに値を格納

CB.SetText Form.TimeText.Value '変数の値をDataObjectに格納する
CB.PutInClipboard 'DataObjectのデータをクリップボードに格納する
AppActivate Application.Caption
Call 時間最終行をセレクトする
ending:
End Sub

お分かりになる方どうぞよろしくお願いします。

No.1 ベストアンサー 回答者： WindFaller 回答日時： 2017/01/08 13:28

こんにちは。

>お分かりになる方どうぞよろしくお願いします。
うーん、何度読んでも、分かりませんね。Form というのはExcel VBAでは直接使わないし、どういう人が書いたかは知りませんが、本当に動くことさえ、そのコードからは読み取れません。それで、私が、VBAのプログラムの力量がないと判断するのは自由だけれども、一度、私の書いたコードを御覧ください。構造的には同じ内容だと思います。内容的には、かなりオーソドックスです。

ご質問者さんのご要望には、特にお応えしていくつもりはありませんが、前からご質問はアップしていたのは見ていましたので、少し考えてみました。なお、以下は正確なストップウォッチとは言えません。浮動小数点誤差も考慮されていません。正確さでは、Win32 APIを使ったほうがよいのですが、ブルースクリーンのリスクが高く、UserFormに取り付けるには、Excel に対する子のWindow になるらしく、手間が増えるようになるようです。

それと、オプションを付けた分だけ、コードは読みにくいようです。

'UserForm モジュール以外のモジュール
Sub UserFormUP()
'起動用のボタン1
　UserForm1.Show 0
End Sub

'UserForm モジュール（添付画像）
Private stpFlg As Boolean
Private FormerTime As Single
Private DiffTime As Single
Private Sub UserForm_Activate()
　　CommandButton1.BackColor = &HC0&
　　DiffTime = 0
　　FormerTime = 0
　　Range("C6:D6").ClearContents
　　Range("R1:R5").ClearContents
End Sub

Private Sub CommandButton1_Click()
　'スタートボタン
　Dim myStartTime As Single
　Dim myTimer As Single
　Dim myTime As Double
　Dim myInterval As Long
　Dim i As Long
　Dim fScnd As Long
　myInterval = 100
　myStartTime = Timer()
　DiffTime = 0
　stpFlg = False
　CommandButton1.BackColor = &H8000000F
　CommandButton2.BackColor = &H8000000D
　If FormerTime = 0 Then
　　Range("C6").Value = "◯"
　End If
　Do While stpFlg = False
　　myTimer = Timer()
　　Do While Timer() - myTimer < myInterval / 1000
　　　DoEvents
　　　If Not stpFlg Then Exit Do
　　Loop
　　DiffTime = (Timer() - myStartTime)
　　myTime = (DiffTime + FormerTime) / (60& * 60 * 24)
　　TextBox1.Text = Format$(myTime, "h:mm:ss")
　　'カウント
　　If Second(myTime) - (fScnd + 1) = 0 Then
　　　 Range("D6").Value = Range("D6").Value + 1
　　End If
　　fScnd = Second(myTime)
　Loop
　'R列の書き込み
　i = Cells(Rows.Count, "R").End(xlUp).Row
　If i > 5 Then MsgBox "これ以上は機能しません。", vbExclamation: Exit Sub
　If Cells(i, "R").Value = "" Then
　　Cells(i, "R").Value = Format$(myTime, "h:mm:ss")
　　Else
　　Cells(i + 1, "R").Value = Format$(myTime, "h:mm:ss")
　End If
　Label1.Caption = FormerTime
　Label2.Caption = DiffTime
　FormerTime = FormerTime + DiffTime　'繰越
　DiffTime = 0
End Sub

Private Sub CommandButton2_Click()
CommandButton1.BackColor = &HC0&
CommandButton2.BackColor = &H8000000F
'ストップボタン
　　stpFlg = True
End Sub
Private Sub UserForm_Terminate()
Unload Me
End 'すべての進行中のマクロは止める
End Sub

この回答へのお礼

ありがとうございました！

お礼日時：2017/01/11 18:23