ExcelのVBAを利用して、ストップウォッチ機能をつけたいと思っております。
現在別の方で作っていただいたのが以下になります。
①ストップウォッチのボタンを押したら、ストップウォッチ画面が表示される。
②表示された画面のスタートをクリックしたら画面に表示されるカウントがスタートされ、
スタートボタンもストップに変更される
③カウント中にストップを押したらスタートボタンに変更され、ストップウォッチの時間がコピーされ、I列の一番下が選択される
④再度スタートをクリックすると②~③が繰り返し行われる
⑤閉じるのマークをクリックするとストップウォッチ画面が消えるというところまではできています。
これを以下の2つの機能を追加したいと思っています。
②スタートをクリックしたときに、C6セルに”〇”を記入、D6セルにもともと入っている数字+1をし、
カウントアップがスタートし、スタートボタンもストップに変わる
③ストップを押したときに、カウントした時間をR1へ記載する。もしR1がすでに入力されているならR2へ、R1もR2も記載されていたらR3へ記載・・・をR5まで行う
今作っているのが以下の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ベストアンサー
- 回答日時:
こんにちは。
>お分かりになる方どうぞよろしくお願いします。
うーん、何度読んでも、分かりませんね。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
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 【VBA】写真の貼り付けコードがうまく機能しません。 5 2022/09/01 18:43
- Excel(エクセル) 2つのVBAを一緒にしたら機能しなくなりました(エクセル) 7 2022/06/02 12:41
- Visual Basic(VBA) ユーザーフォーム「frm_基本❶」を立ち上げると新規で入力する行数を右下のNoとして表示しています。 1 2023/03/16 19:02
- Visual Basic(VBA) InputBoxでキャンセルボタンを押したらファイル自体を閉じたい 3 2022/07/23 17:52
- Visual Basic(VBA) 【追加】ファイルを閉じてダイアログで保存した時だけ処理の実行をする 3 2022/03/23 15:43
- Visual Basic(VBA) 3つのプロシージャをまとめたら実行時エラー発生で対応不能 6 2022/05/17 01:47
- Visual Basic(VBA) 検索のユーザーフォームの表示について 1 2023/03/27 23:31
- Visual Basic(VBA) 【Excel VBA】自動メール送信の機能追加 5 2022/09/29 12:53
- Visual Basic(VBA) VBAのユーザーフォームのテキストボックスに入力制限をしたい 6 2022/11/15 08:28
- Visual Basic(VBA) VBAでoutlook365が起動しません。 4 2022/08/25 13:31
このQ&Aを見た人はこんなQ&Aも見ています
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
首吊りどこ締めるの
-
至急!尿検査前日にオナニーし...
-
白血球が多いとどんな心配があ...
-
腕を見たら黄色くなってる部分...
-
検便についてです。 便は取れた...
-
彼女のことが好きすぎて彼女の...
-
精子が黄色?
-
勃起する時って痛いんですか? ...
-
尿検査前日に自慰行為した時の...
-
尿検査の前日は自慰控えたほう...
-
口の中に黒い血の塊
-
これって喉仏ですか? 私は女性...
-
精子に血が・・・
-
中出しをするとお腹が痛い・・・。
-
納豆食べた後の尿の納豆臭は何故?
-
甲状腺腫れ
-
EXCELで式からグラフを描くには?
-
EXCELで条件付き書式で空白セル...
-
筋トレするとチンコが縮んじゃ...
-
爪が紫色?
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
至急!尿検査前日にオナニーし...
-
首吊りどこ締めるの
-
尿検査の前日は自慰控えたほう...
-
尿検査前日に自慰行為した時の...
-
検便についてです。 便は取れた...
-
白血球が多いとどんな心配があ...
-
中出しをするとお腹が痛い・・・。
-
射精をして1週間以内に尿検査を...
-
彼女のことが好きすぎて彼女の...
-
腕を見たら黄色くなってる部分...
-
勃起する時って痛いんですか? ...
-
変な話しになります。尿検査で...
-
これって喉仏ですか? 私は女性...
-
EXCELで条件付き書式で空白セル...
-
男です。昨日の午後3時くらいに...
-
今朝、毎朝の習慣でオナニーし...
-
納豆食べた後の尿の納豆臭は何故?
-
1日前の検尿
-
値が入っているときだけ計算結...
-
精子が黄色?
おすすめ情報