こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

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]・・・

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

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

投稿日時 - 2018-12-09 13:47:15

QNo.9566149

困ってます

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(5)

ANo.5

>t = ThisWorkbook.Sheets(1).Cells(15, 7).Value 'G15

t = 5
あるいは、
期待する秒数(30秒?)にしてみてください。

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

投稿日時 - 2018-12-28 17:56:58

補足

シート内容を全数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%ほどです。

投稿日時 - 2018-12-31 15:36:51

ANo.4

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

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

投稿日時 - 2018-12-24 20:26:06

補足

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

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

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

投稿日時 - 2018-12-28 16:42:36

ANo.3

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

また、
>このマクロを終了させるのは、
>マウスで直接別のセルをアクティブにしたとき、または、
>矢印キーでアクティブセルを移動したときなどにしたいですが
下向きの矢印キーが押されたら
即座に終了するようにしてみました。
(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

投稿日時 - 2018-12-10 12:42:10

補足

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

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

投稿日時 - 2018-12-10 22:43:27

ANo.2

>なお、
>[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

投稿日時 - 2018-12-09 20:03:49

補足

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

投稿日時 - 2018-12-24 18:15:39

ANo.1

[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

投稿日時 - 2018-12-09 17:18:26

あなたにオススメの質問