Excel2002マクロ セルのアクティブ状態移動

質問

お世話になります

このようなことができるのかどうか分からないのですが、もしできるのであればその方法を知りたいです。
実行する内容は、特定のセル範囲で、指定した時間毎にセルのアクティブ状態を移動するというものです。

対象となる特定のセル範囲は、最大で([A1]～[J9])+([A10]～[G10])の合計97個のセルです。
このセル範囲は、その日によって変わります。
より上の行を優先にして、更に、より左のセルを優先にして、36個であったり、47個であったり、49個であったり、ほかの数の場合もあります。
この対象となる特定のセルの個数は[E14]のセルに入っている値で指定しています。

その日対象となる範囲のセルには数値が入っているかまたは空欄のどちらかです。
入っている数値は1～97の範囲でランダムで、重複する数値はありません。

アクティブ状態の移動先は、移動前にアクティブになっているセルの右隣。
セルのアクティブ状態が対象範囲の一番右端まで行った場合、次はその下の行の左端のセルです。
更に、セルのアクティブ状態がその日の対象範囲の一番右下まで行った場合、次は[A1]です。

アクティブ状態が移動する時間間隔は[G15]のセルに入っている時間です。
マクロ開始後[G15]のセルに入っている時間経過後、セルのアクティブ状態が移動します。
更に[G15]のセルに入っている時間経過後、その次のセルがアクティブになっていきます。

例えば次の条件の場合
　対象となる特定のセル範囲は([A1]～[J3])＋([A4]～[B4])
　マクロ開始前のアクティブセルは[G3]
　[E14]のセルに入っている値は32
　[G15]のセルに入っている時間は30秒
の場合
マクロ開始30秒後、アクティブセルは[H3]になります。
その後、30秒毎にアクティブ状態は移動していきます
[I3][J3][A4][B4][A1][B1][C1]・・・

このマクロを終了させるのは、マウスで直接別のセルをアクティブにしたとき、または、矢印キーでアクティブセルを移動したときなどにしたいですが、可能な方法が限られているようでしたらその方法にします。

以上よろしくお願いします。

回答No.5

HohoPapa

>t = ThisWorkbook.Sheets(1).Cells(15, 7).Value 'G15
を
t = 5
あるいは、
期待する秒数（30秒？）にしてみてください。

それでも何やらホワイトアウトするようであれば、
マクロの問題ではなく
課題シートの再描写にCPUが食われている可能性を疑います。
シートに内容を全数Nullにして試してください。

補足

シート内容を全数Null
というのは、目的のシートのセル全部を空白にするということでよろしいでしょうか？

この場合、[t]だけではなく[e]も指定する必要があり、[e=60]で試行しました。
また、そのため[Cells(14, 5)]を含む[if文]を無効にしました。

全コードは次の通りです。

Option Explicit

Public Declare Function GetAsyncKeyState Lib "User32.dll" ( _
　　　　　　　　　　　　　　　　ByVal vKey As Long _
　　　　　　　　　　　　　　　　) As Long
Public Const VK_DOWN = &H28 '[↓]

Dim IngFlg As Boolean

Sub Sample()
　Dim i As Long
　Dim s As Long
　Dim e As Long
　Dim t As Long

　s = ((ActiveCell.Row - 1) * 10) + ActiveCell.Column
'　e = ThisWorkbook.Sheets(1).Cells(14, 5).Value 'E14
　e = 60
'　t = ThisWorkbook.Sheets(1).Cells(15, 7).Value 'G15
　t =5
　If s >= e Then　　　　'<===バグがあったので今回修正
　　i = 0
　Else
　　i = s
　End If
　IngFlg = True
　Do
'　　If ThisWorkbook.Sheets(1).Cells(14, 5).Value = "" Then Exit Sub
　　If IngFlg = False Then Exit Sub
　　WaitFor t
　　CellSel i
　　i = i + 1
　　If i >= e Then
　　　i = 0
　　End If
　Loop

End Sub

Sub LoopEnd()
　IngFlg = False
End Sub

'//　番号でセルを選択
Function CellSel(CntNum As Long)
　Dim RowNum As Long
　Dim ColNum As Long
　RowNum = Int(CntNum / 10) + 1
　ColNum = CntNum Mod 10 + 1
　ThisWorkbook.Sheets(1).Cells(RowNum, ColNum).Select
End Function

'//　指定した秒だけ停止する関数
Function WaitFor(ByVal second As Integer)
　Dim futureTime As Date
　futureTime = DateAdd("s", second, Now)
　While Now < futureTime
'　　If ThisWorkbook.Sheets(1).Cells(14, 5).Value = "" Then Exit Function
　　If IngFlg = False Then Exit Function
　　If GetAsyncKeyState(VK_DOWN) Then
　　　IngFlg = False
　　　Exit Function
　　End If
　　DoEvents
　Wend
End Function

これを使っている装置は、常には手元にありません。
cpu100%になっても、他の処理を受け付けないということはないのですが、応答がとても遅くなります。

手元にあるのはWindows10で、ずっと性能が良いものですが、この装置で試行しました。
cpu使用率60%ほどになります。
上記コードの場合と、手を加えない場合とで変わりありません。
このマクロを実行しないときは、cpu5%ほどです。

回答No.4

HohoPapa

>このマクロを実行すると、CPU使用率100%になってしまいます。
１回／秒の処理を繰り返すコードですので
呆れるほど非力なCPUでもそれなりに動作するはずです。

>そのため「 * 60 * 60 * 24」を付けて動作確認中です。
この対応をしたコードを示してみてください。

補足

対応をしたコードは次の通りです。

t = ThisWorkbook.Sheets(1).Cells(15, 7).Value 'G15
これを、次のようにしました。
t = ThisWorkbook.Sheets(1).Cells(15, 7).Value * 60 * 60 * 24 'G15

試しに、このコードを変更せず元のままにして、時間の入るセルには時間ではなく数値で入れてみましたが、結果は同じでした。

回答No.3

HohoPapa

セルの移動範囲の最後のセルが選択された状態でマクロがスタートすると
そのセルの次のセル
（右側のセル、または、次行先頭のセル）
がアクティブになってしまうバグがあるので修正しました。

また、
>このマクロを終了させるのは、
>マウスで直接別のセルをアクティブにしたとき、または、
>矢印キーでアクティブセルを移動したときなどにしたいですが
下向きの矢印キーが押されたら
即座に終了するようにしてみました。
（APIを使うのでちょっと難易度があがります。）

Option Explicit

Public Declare Function GetAsyncKeyState Lib "User32.dll" ( _
　　　　　　　　　　　　　　　　ByVal vKey As Long _
　　　　　　　　　　　　　　　　) As Long
Public Const VK_DOWN = &H28 '[↓]

Dim IngFlg As Boolean

Sub Sample()
　Dim i As Long
　Dim s As Long
　Dim e As Long
　Dim t As Long

　s = ((ActiveCell.Row - 1) * 10) + ActiveCell.Column
　e = ThisWorkbook.Sheets(1).Cells(14, 5).Value 'E14
　t = ThisWorkbook.Sheets(1).Cells(15, 7).Value 'G15
　If s >= e Then　　　　'<===バグがあったので今回修正
　　i = 0
　Else
　　i = s
　End If
　IngFlg = True
　Do
　　If ThisWorkbook.Sheets(1).Cells(14, 5).Value = "" Then Exit Sub
　　If IngFlg = False Then Exit Sub
　　WaitFor t
　　CellSel i
　　i = i + 1
　　If i >= e Then
　　　i = 0
　　End If
　Loop

End Sub

Sub LoopEnd()
　IngFlg = False
End Sub

'//　番号でセルを選択
Function CellSel(CntNum As Long)
　Dim RowNum As Long
　Dim ColNum As Long
　RowNum = Int(CntNum / 10) + 1
　ColNum = CntNum Mod 10 + 1
　ThisWorkbook.Sheets(1).Cells(RowNum, ColNum).Select
End Function

'//　指定した秒だけ停止する関数
Function WaitFor(ByVal second As Integer)
　Dim futureTime As Date
　futureTime = DateAdd("s", second, Now)
　While Now < futureTime
　　If ThisWorkbook.Sheets(1).Cells(14, 5).Value = "" Then Exit Function
　　If IngFlg = False Then Exit Function
　　If GetAsyncKeyState(VK_DOWN) Then
　　　IngFlg = False
　　　Exit Function
　　End If
　　DoEvents
　Wend
End Function

補足

ご回答ありがとうございます。
[G15]に入っている値は、数値ではなく時間で入っています。
そのセルの書式は時刻です。
そのため「 * 60 * 60 * 24」を付けて動作確認中です。
また、実際には式が入っていて、その結果の値は整数ではありません。

今のところ、[G15]の時間よりも少し長い時間が掛かっているようです。
私のPCの性能が低いためなのか？・・・
検証中です。

回答No.2

HohoPapa

>なお、
>[E14]を空（Null）にしてVBAが停止するまで、最大、
>[G15]のセルに埋まっている秒数が必要です。
これを改善し、即座に終了するようにしてみました。

更に
Sub LoopEnd()を用意しました。
終了するためのボタンを配置しクリックする
あるいは任意の手段で
Sub LoopEnd()　を呼び出せば
即座に終わるようにしてみました。

Option Explicit

Dim IngFlg As Boolean

Sub Sample()
　Dim i As Long
　Dim s As Long
　Dim e As Long
　Dim t As Long

　s = ((ActiveCell.Row - 1) * 10) + ActiveCell.Column
　e = ThisWorkbook.Sheets(1).Cells(14, 5).Value 'E14
　t = ThisWorkbook.Sheets(1).Cells(15, 7).Value 'G15
　If s > e Then
　　i = 0
　Else
　　i = s
　End If
　IngFlg = True
　Do
　　If ThisWorkbook.Sheets(1).Cells(14, 5).Value = "" Then Exit Sub
　　If IngFlg = False Then Exit Sub
　　WaitFor t
　　CellSel i
　　i = i + 1
　　If i >= e Then
　　　i = 0
　　End If
　Loop

End Sub

Sub LoopEnd()
　IngFlg = False
End Sub

'//　番号でセルを選択
Function CellSel(CntNum As Long)
　Dim RowNum As Long
　Dim ColNum As Long
　RowNum = Int(CntNum / 10) + 1
　ColNum = CntNum Mod 10 + 1
　ThisWorkbook.Sheets(1).Cells(RowNum, ColNum).Select
End Function

'//　指定した秒だけ停止する関数
Function WaitFor(ByVal second As Integer)
　Dim futureTime As Date
　futureTime = DateAdd("s", second, Now)
　While Now < futureTime
　　If ThisWorkbook.Sheets(1).Cells(14, 5).Value = "" Then Exit Function
　　If IngFlg = False Then Exit Function
　　DoEvents
　Wend
End Function

補足

検証は続いていますが、一つ困った状態になっています。
このマクロを実行しているExcelは、とても古いパソコンに入っています。
CPUは450Mhzです。
このマクロを実行すると、CPU使用率100%になってしまいます。
発熱も大きく、他のファイル処理などをするのが難しくなります。
これを改善するにはどうしたら良いでしょうか。
お手数おかけしますが、よろしくお願いします。

回答No.1

HohoPapa

[G15]のセルには秒数が埋まっている。
終了する場合は
[E14]を空（Null）にするという条件でよければ
次のようなコードでいかがでしょうか？

なお、
[E14]を空（Null）にしてVBAが停止するまで、最大、
[G15]のセルに埋まっている秒数が必要です。

即座に終了したい場合は
[Ctrl] キーを押したまま [Break] キーを押します。

Option Explicit

Sub Sample()
　Dim i As Long
　Dim s As Long
　Dim e As Long
　Dim t As Long

　s = ((ActiveCell.Row - 1) * 10) + ActiveCell.Column
　e = ThisWorkbook.Sheets(1).Cells(14, 5).Value 'E14
　t = ThisWorkbook.Sheets(1).Cells(15, 7).Value 'G15
　If s > e Then
　　i = 0
　Else
　　i = s
　End If
　Do
　　If ThisWorkbook.Sheets(1).Cells(14, 5).Value = "" Then Exit Sub
　　WaitFor t
　　CellSel i
　　i = i + 1
　　If i >= e Then
　　　i = 0
　　End If
　Loop

End Sub

'//　番号でセルを選択
Function CellSel(CntNum As Long)
　Dim RowNum As Long
　Dim ColNum As Long
　RowNum = Int(CntNum / 10) + 1
　ColNum = CntNum Mod 10 + 1
　ThisWorkbook.Sheets(1).Cells(RowNum, ColNum).Select
End Function

'//　指定した秒だけ停止する関数
Function WaitFor(ByVal second As Integer)
　Dim futureTime As Date
　futureTime = DateAdd("s", second, Now)
　While Now < futureTime
　　DoEvents
　Wend
End Function