１秒毎にセルの値を１ずつ増やしたいのですが

質問

いつも難しいマクロでｇｏｏの皆さんには大変お世話になっています。
よろしくお願いします。
エクセルで、シート上でクリックを一回したらセルの値が１秒ごとに１ずつ増えるようにしたいのです。再度クリックしたらカウントを中断して０に戻りまた１秒ごとに１ずつセルの値を増やしたいです。数値の最高値は別のセルに書いてある数値です。
ちょっと難問ですがどうかよろしくお願いします。

回答No.1

siddhaartha · ベストアンサー

要件に一番近そうなマクロを作ってみました。ただし数点制約があります。
・ExcelVBAではマルチスレッドが実現できないので１セル毎でしかカウントできません。
・クリックイベントは無いので、ボタン(CommandButton1)のクリックイベントで
　カウントのON／OFFを行っています。

Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public blCountFlg As Boolean

Private Sub CommandButton1_Click()
blCountFlg = Not blCountFlg
Call prc_Count(ActiveCell, Cells(1, 1))
End Sub

Private Sub prc_Count(ByVal Target As Range, MaxCount As Long)
Dim lnStart As Long
Dim lnCount As Long
lnStart = GetTickCount

Do While (blCountFlg And lnCount < MaxCount)
Sleep (100)
lnCount = (GetTickCount - lnStart) / 1000
Target.Value = lnCount
DoEvents
Loop
End Sub

回答No.3

nicotinism

あんまり、パッとしない案です。
シート１のイベントに

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'A1 微調整用
'B1 設定秒数
'C1 開始
'C2 停止
'D1 経過秒表示
'E1 開始時間
'F1 終了時間

Dim i As Long
Dim tt As Single
Dim tA As Single

If Target.Address <> "$C$1" Then Exit Sub

Range("c1").Value = "Start"
Range("c2").Value = "Stop"
Range("d1") = 0
Range("F1") = ""
Range("G1") = ""

tA = Range("A1").Value
Range("E1") = Timer

Do Until i > Range("B1").Value - 1
　　If ActiveCell.Address = "$C$2" Then
　　　　Exit Do
　　　　Exit Sub
　　End If
　　tt = Timer
　　　　Do While Timer < tt + tA
　　　　　　DoEvents　　　　　　　　' 他のプロセスに制御を渡します。
　　　　Loop
　　i = i + 1
　　Range("D1") = i
Loop
Range("F1") = Timer
Range("G1") = "誤差 " & Range("F1") - Range("E1") - Range("B1").Value
End Sub

んで
セル A1 に 1
セル B1 に 10
を入れてセルC1を選択してみてください。停止ははC2を選択。

回答No.2

toshi_2000

マクロは、次の通りです。（数値の最高値には未対応）

Sub Test()
If Cells(1, 1) <> 0 Then
Cells(1, 1) = 0
Application.OnTime Now + TimeValue("00:00:01"), "test2", SCHEDULE:=False
End If
Test2
End Sub

Sub Test2()
Cells(1, 1) = Cells(1, 1) + 1
Application.OnTime Now + TimeValue("00:00:01"), "test2"
End Sub