Do Loop Until 条件停止後のセル位置について

質問

こんにちは。いつもお世話になります。
ただ今、シート上の緑色のセルをカーソルで移動させるプログラムを
作っています。
停止の条件は[SHIFT]キーを押すと止まります。
一応は停止しますがセルの位置がズレてしまい、なんとか現在選択
している位置で停止できないものかと思い、アドバイス願います。
コードは下記になります。
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vkey As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Key_Sample()
Cells(1, 1).Select
On Error Resume Next
'繰返し開始
Do
'上方向のキー入力判定
If GetAsyncKeyState(38) <> 0 Then
Selection.Interior.ColorIndex = xlNone
ActiveCell.Offset(-1, 0).Select
Selection.Interior.ColorIndex = 4
Else
Selection.Interior.ColorIndex = 4
End If
'下方向のキー入力判定
If GetAsyncKeyState(40) <> 0 Then
Selection.Interior.ColorIndex = xlNone
ActiveCell.Offset(1, 0).Select
Selection.Interior.ColorIndex = 4
Else
Selection.Interior.ColorIndex = 4
End If
'左方向のキー入力判定
If GetAsyncKeyState(37) <> 0 Then
Selection.Interior.ColorIndex = xlNone
ActiveCell.Offset(0, -1).Select
Selection.Interior.ColorIndex = 4
Else
Selection.Interior.ColorIndex = 4
End If
'右方向のキー入力判定
If GetAsyncKeyState(39) <> 0 Then
Selection.Interior.ColorIndex = xlNone
ActiveCell.Offset(0, 1).Select
Selection.Interior.ColorIndex = 4
Else
Selection.Interior.ColorIndex = 4
ActiveCell.Select
End If
Sleep 100
Loop Until GetAsyncKeyState(16) <> 0
End Sub

回答No.5

noname#144013

こんにちは。#3です。

#3に上げたサンプルではアクティブなセルと緑色で表示するセルが時々ずれる
場合があった為、それを改善したバージョンを作ってみました。
もし宜しければ試してみて下さい。
※ただし、方向キーリピート時のセル移動開始までに少し時間がかかります。
※今回はSleep関数は使用していません。

■サンプルマクロ（修正版）
　注）インデントの為、全角スペースを入れています。
　　　ExcelのVBAモジュールに貼り付ける際は、タブor半角スペースに置換して下さい。

'/////↓ここから/////
Option Explicit

'仮想キーコードの定義
Public Const VK_SHIFT = &H10　 '[Shift]キー
Public Const VK_UP = &H26　　　'[↑]キー
Public Const VK_DOWN = &H28　　'[↓]キー
Public Const VK_LEFT = &H25　　'[←]キー
Public Const VK_RIGHT = &H27　 '[→]キー

'WinAPIの参照定義
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vkey As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'
'キー操作サンプル
'
Sub Key_Sample()

　　Dim iCheck As Integer　 '入力キーの識別コード
　　Dim iUp As Integer　　　'[↑]キー検出用
　　Dim iDown As Integer　　'[↓]キー検出用
　　Dim iLeft As Integer　　'[←]キー検出用
　　Dim iRight As Integer　 '[→]キー検出用
　　Dim iShift As Integer　 '[Shift]キー検出用
　　Dim cyMax As Long　　　 'セルの最大行数
　　Dim cxMax As Long　　　 'セルの最大カラム数
　　Dim cy As Long　　　　　'前回のセル位置（行位置）
　　Dim cx As Long　　　　　'前回のセル位置（カラム位置）
　　Dim cy2 As Long　　　　 '今回のセル位置（行位置）
　　Dim cx2 As Long　　　　 '今回のセル位置（カラム位置）

　　cyMax = Rows.Count　　　'セルの最大行数の取得
　　cxMax = Columns.Count　 'セルの最大カラム数の取得

　　'最初に全セルをクリアする
　　Cells.Select
　　Selection.Clear

　　'開始セルの選択＆カラー設定
　　cy = 1: cx = 1
　　Cells(cy, cx).Select
　　Cells(cy, cx).Interior.ColorIndex = 4

　　'エラー処理の設定（エラー発生時の停止回避）
　　On Error Resume Next

　　'ループ処理１：全体処理（[Shift]キー入力時にループ終了）
　　Do
　　　　'ループ処理２：キー入力監視（指定のキーが押されるまでループ）
　　　　iCheck = 0
　　　　Do
　　　　　　'入力キー検出
　　　　　　iUp = GetAsyncKeyState(VK_UP) And &H8000
　　　　　　iDown = GetAsyncKeyState(VK_DOWN) And &H8000
　　　　　　iLeft = GetAsyncKeyState(VK_LEFT) And &H8000
　　　　　　iRight = GetAsyncKeyState(VK_RIGHT) And &H8000
　　　　　　iShift = GetAsyncKeyState(VK_SHIFT) And &H8000

　　　　　　'入力キー別に識別コードセット
　　　　　　If iUp Then
　　　　　　　　iCheck = 1　'[↑]キー
　　　　　　ElseIf iDown Then
　　　　　　　　iCheck = 2　'[↓]キー
　　　　　　ElseIf iLeft Then
　　　　　　　　iCheck = 3　'[←]キー
　　　　　　ElseIf iRight Then
　　　　　　　　iCheck = 4　'[→]キー
　　　　　　ElseIf iShift Then
　　　　　　　　iCheck = 5　'[Shift]キー
　　　　　　End If

　　　　　　DoEvents　　'システムに制御を渡す（※溜まっているメッセージの処理）
　　　　Loop While iCheck = 0　 '指定キーの入力が無ければループ

　　　　'今回のセル位置取得（Activeセル）
　　　　cy2 = ActiveCell.Row
　　　　cx2 = ActiveCell.Column

　　　　'今回セル位置と前回セル位置が違ったら表示更新
　　　　If cy <> cy2 Or cx <> cx2 Then
　　　　　　Cells(cy, cx).Interior.ColorIndex = xlNone　'前回セル位置のカラーをクリア
　　　　　　Cells(cy2, cx2).Interior.ColorIndex = 4　　 '今回セル位置のカラーをセット
　　　　　　cy = cy2　　'セル位置のセーブ(前回値へ）
　　　　　　cx = cx2　　'セル位置のセーブ(前回値へ）
　　　　End If

　　Loop Until iCheck = 5　 '[Shift]キーが押されてなければループ

　　'エラー処理の解除
　　On Error GoTo 0

End Sub
'/////↑ここまで/////

回答No.4

DreamyCat

矢印キーで操作するとマクロを使わないときの
キー入力がバッファに溜まり、Shiftでループを抜けたときに
吐き出されるために、操作したい移動量の２倍の移動位置が
Activecellになってしまうようです。
　Activecell.selectではなく、Selection.offsetを使えば
もしかすると大丈夫かも。

ループを使わなくてもこれで面倒なく同じことが可能です。
ただし、コントロールパネルの「キーボード」のところで
時間間隔をできるだけ小さくしておかないと
移動が遅くなります。
Option Explicit
Dim rw as long , clm as long

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'中止したいときはここに抜けるための処理を書く　
　If rw = 0 Then rw = 1
　If clm = 0 Then clm = 1
　　Cells(rw, clm).Interior.ColorIndex = xlNone
　　　Target.Interior.ColorIndex = 4
　rw = Target.Row
　clm = Target.Column
End Sub

ご自分で作成されたコードは変数を使うとごく短いコードにできます。
VBAに慣れてきたら　cells(i,j). などの形式で書く工夫をしてみてください。

回答No.3

noname#144013

こんにちは。

以下のサンプルは一例です。
もっとスマートな方法があるかもしれません。
また、以下のサンプルが質問者さんの使用環境で上手く動作するかどうかは判りません。
上手くいかなかった場合は、すみません。

■サンプルの補足
１．キー入力処理の遅延をできるだけ少なくするために、ループ処理を２重化して「キー入力待ち」専用の
　ループ処理を全体処理のループ内に設けてみました。
　　◎ループ１（外側）　：　全体処理
　　　　　　　　　　　　　　　　・[Shift]キーが押されるまで、キー入力監視＆セル移動処理を繰り返します。
　　◎ループ２（内側）　：　キー入力用のループ処理
　　　　　　　　　　　　　　　　・対象のキーが押されるまで、キー入力監視を行います。

２．ループ内のSleep関数ですが、Sleepしている間、画面更新とかマウスorキーイベントなどのメッセージ
　処理が停止してしまうので、適当なところでDoEvents関数を入れてシステムに制御を渡すようにして
　います。
　　※スリープ時間は使用環境により調整する必要があると思います。

３．現在のセル位置（行位置、カラム位置）を保持して、セル移動時の表示更新処理で参照＆更新する
　ようにしています。

■サンプルマクロ
　※標準モジュール内のコード
　注）インデントの為、全角スペースを入れています。
　　　ExcelのVBAモジュールに貼り付ける際は、タブor半角スペースに置換して下さい。

'/////↓ここから/////
Option Explicit

'仮想キーコードの定義
Public Const VK_SHIFT = &H10　 '[Shift]キー
Public Const VK_UP = &H26　　　'[↑]方向キー
Public Const VK_DOWN = &H28　　'[↓]方向キー
Public Const VK_LEFT = &H25　　'[←]方向キー
Public Const VK_RIGHT = &H27　 '[→]方向キー

'WinAPIの参照定義
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vkey As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'
'キー操作サンプル
'
Sub Key_Sample()

　　Dim iCheck As Integer　 '入力キーの識別コード
　　Dim cy As Long　　　　　'現在のセル位置（行位置）
　　Dim cx As Long　　　　　'現在のセル位置（カラム位置）
　　Dim cyMax As Long　　　 'セルの最大行数
　　Dim cxMax As Long　　　 'セルの最大カラム数

　　cyMax = Rows.Count　　　'セルの最大行数の取得
　　cxMax = Columns.Count　 'セルの最大カラム数の取得

　　'最初に全セルをクリアする
　　Cells.Select
　　Selection.Clear

　　'開始セルの選択＆カラー設定
　　cy = 1
　　cx = 1
　　Cells(cy, cx).Select
　　Selection.Interior.ColorIndex = 4

　　'エラー処理の設定（エラー発生時の停止回避）
　　On Error Resume Next

　　'ループ処理１：全体処理（[Shift]キー入力時にループ終了）
　　Do

　　　　'ループ処理２：キー入力監視（指定のキーが押されるまでループ）
　　　　iCheck = 0
　　　　Do
　　　　　　'入力キー判定（入力キー別に識別コードセット）
　　　　　　If (GetAsyncKeyState(VK_UP) And &H8000) Then
　　　　　　　　iCheck = 1　'[↑]方向キー
　　　　　　End If
　　　　　　If (GetAsyncKeyState(VK_DOWN) And &H8000) Then
　　　　　　　　iCheck = 2　'[↓]方向キー
　　　　　　End If
　　　　　　If (GetAsyncKeyState(VK_LEFT) And &H8000) Then
　　　　　　　　iCheck = 3　'[←]方向キー
　　　　　　End If
　　　　　　If (GetAsyncKeyState(VK_RIGHT) And &H8000) Then
　　　　　　　　iCheck = 4　'[→]方向キー
　　　　　　End If
　　　　　　If (GetAsyncKeyState(VK_SHIFT) And &H8000) Then
　　　　　　　　iCheck = 5　'[Shift]キー
　　　　　　End If

　　　　　　Sleep 50　　'スリープ処理（※スリープ時間は環境により要調整）
　　　　　　DoEvents　　'システムに制御を渡す（※溜まっているメッセージの処理）

　　　　Loop While iCheck = 0　 '指定キーの入力が無ければループ

　　　　'方向キー入力時の処理
　　　　If iCheck >= 1 And iCheck <= 4 Then

　　　　　　'移動前セルのカラーをクリア
　　　　　　Cells(cy, cx).Interior.ColorIndex = xlNone

　　　　　　'入力キー別のセル位置更新
　　　　　　Select Case iCheck
　　　　　　Case 1　'上方向キーの入力
　　　　　　　　If cy > 1 Then cy = cy - 1
　　　　　　Case 2　'下方向キーの入力
　　　　　　　　If cy < cyMax Then cy = cy + 1
　　　　　　Case 3　'左方向キーの入力
　　　　　　　　If cx > 1 Then cx = cx - 1
　　　　　　Case 4　'右方向キーの入力
　　　　　　　　If cx < cxMax Then cx = cx + 1
　　　　　　End Select

　　　　　　'移動先セルの選択＆カラー設定
　　　　　　Cells(cy, cx).Select
　　　　　　Selection.Interior.ColorIndex = 4

　　　　End If

　　Loop Until iCheck = 5　 '[Shift]キーが押されてなければループ

　　'エラー処理の解除
　　On Error GoTo 0

End Sub
'/////↑ここまで/////

以上です。参考になれば幸いです。

回答No.2

noname#102340

Dim gyo As Long, retu As Long
とか宣言する。
：
：
End If
gyo = Selection.Row
retu = Selection.Column
Sleep 100
Loop Until GetAsyncKeyState(16) <> 0
DoEvents
Cells(gyo, retu).Select
End Sub

回答No.1

imogasi

当方でやってみた
A1セルから、矢印キーの方向に従って、移動した軌跡のセルのパターン色が緑色になりました。
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vkey As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Key_Sample()
Cells(1, 1).Select
On Error Resume Next
'繰返し開始
Do
'上方向のキー入力判定
DoEvents
If GetAsyncKeyState(38) <> 0 Then
'Selection.Interior.ColorIndex = xlNone
ActiveCell.Offset(-1, 0).Select
Selection.Interior.ColorIndex = 4
Else
Selection.Interior.ColorIndex = 4
End If
'下方向のキー入力判定
If GetAsyncKeyState(40) <> 0 Then
'Selection.Interior.ColorIndex = xlNone
ActiveCell.Offset(1, 0).Select
Selection.Interior.ColorIndex = 4
Else
Selection.Interior.ColorIndex = 4
End If
'左方向のキー入力判定
If GetAsyncKeyState(37) <> 0 Then
'Selection.Interior.ColorIndex = xlNone
ActiveCell.Offset(0, -1).Select
Selection.Interior.ColorIndex = 4
Else
Selection.Interior.ColorIndex = 4
End If
'右方向のキー入力判定
If GetAsyncKeyState(39) <> 0 Then
'Selection.Interior.ColorIndex = xlNone
ActiveCell.Offset(0, 1).Select
Selection.Interior.ColorIndex = 4
Else
Selection.Interior.ColorIndex = 4
ActiveCell.Select
End If
Sleep 100
Loop Until GetAsyncKeyState(16) <> 0
End Sub
Doiventsを入れたことと、ｘｌNoneの行をコメント化しました。
SHIFキーを押すとプログラムが止まりました。
動きが私のマシンでは、ぎこちないですが。
ーーー
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vkey As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Key_Sample()
Cells(1, 1).Select
On Error Resume Next
'繰返し開始
Do
DoEvents
'上方向のキー入力判定
If GetAsyncKeyState(38) <> 0 Then
Selection.Interior.ColorIndex = xlNone
'ActiveCell.Offset(-1, 0).Select
Selection.Interior.ColorIndex = 4
Else
Selection.Interior.ColorIndex = 4
End If
'下方向のキー入力判定
If GetAsyncKeyState(40) <> 0 Then
ActiveCell.Offset(1, 0).Select
Selection.Interior.ColorIndex = xlNone
'ActiveCell.Offset(1, 0).Select
Selection.Interior.ColorIndex = 4
Else
Selection.Interior.ColorIndex = 4
End If
'左方向のキー入力判定
If GetAsyncKeyState(37) <> 0 Then
Selection.Interior.ColorIndex = xlNone
'ActiveCell.Offset(0, -1).Select
Selection.Interior.ColorIndex = 4
Else
Selection.Interior.ColorIndex = 4
End If
'右方向のキー入力判定
If GetAsyncKeyState(39) <> 0 Then
Selection.Interior.ColorIndex = xlNone
'ActiveCell.Offset(0, 1).Select
Selection.Interior.ColorIndex = 4
Else
Selection.Interior.ColorIndex = 4
ActiveCell.Select
End If
Sleep 100
Loop Until GetAsyncKeyState(16) <> 0
End Sub
でも出来ました。
ーーー
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vkey As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Key_Sample()
Cells(1, 1).Select
On Error Resume Next
'繰返し開始
Do
DoEvents
ActiveCell.Interior.ColorIndex = 4
'上方向のキー入力判定
If GetAsyncKeyState(38) <> 0 Then
ActiveCell.Offset(1, 0).Interior.ColorIndex = xlNone
'ActiveCell.Offset(-1, 0).Select
'ActiveCell.Interior.ColorIndex = 4
'Else
'Selection.Interior.ColorIndex = 4
End If
'下方向のキー入力判定
If GetAsyncKeyState(40) <> 0 Then
'ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(-1, 0).Interior.ColorIndex = xlNone
ActiveCell.Offset(-2, 0).Interior.ColorIndex = xlNone
'ActiveCell.Offset(1, 0).Select
'ActiveCell.Interior.ColorIndex = 4
'Else
'Selection.Interior.ColorIndex = 4
End If
'左方向のキー入力判定
If GetAsyncKeyState(37) <> 0 Then
ActiveCell.Offset(0, 1).Interior.ColorIndex = xlNone
ActiveCell.Offset(0, 2).Interior.ColorIndex = xlNone
'ActiveCell.Offset(0, -1).Select
'ActiveCell.Interior.ColorIndex = 4
'Else
'Selection.Interior.ColorIndex = 4
End If
'右方向のキー入力判定
If GetAsyncKeyState(39) <> 0 Then
ActiveCell.Offset(0, -1).Interior.ColorIndex = xlNone
ActiveCell.Offset(0, -2).Interior.ColorIndex = xlNone
'ActiveCell.Offset(0, 1).Select
'ActiveCell.Interior.ColorIndex = 4
'Else
'Selection.Interior.ColorIndex = 4
'ActiveCell.Select
End If
Sleep 100
Loop Until GetAsyncKeyState(16) <> 0
End Sub
でゆっくり矢印キーを押すと緑色のセルがかなりの確率で移動します。
ーーー
やはり矢印キーを検知するタイミングと処理が合わないのだと思います。
APIは使い慣れないので、どうすればタイミングが合うのか、わかりません。
上記例は回答になってないかも知れません。
＝＝＝
私も同じような事を考えたとき
VBAのSelection＿Changeイベントで考えた記憶があります。
ただし直前のセル番地を記憶しないとなりません。
Public m As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Selection.Interior.ColorIndex = 4
m.Interior.ColorIndex = xlNone
Set m = Selection
End Sub
’先に１度実行
Sub test01()　'初期設定　先に実行
Set m = Range("A1")
End Sub
シート状で、矢印キーでセルを移動すると順に緑色セルが移動しているように見える。

補足

imogasiさんアドバイスどうもです。
'Selection.Interior.ColorIndex = xlNone
を外して動きが変わるとは意外でした。
Sleepの値と、shiftを押す時間長に問題が有る様な、無い様な
それでいて移動前にセルを白→移動後にセルを緑
の順序にも問題有る様な、無い様な？
この2点に絞って値と順序変えつつ試してみます。
最近API覚えようと思い、試行錯誤していまして、
分からない上に分からない質問してすみませんでした。
もう少しあれこれ触ってみます。