- ベストアンサー
ExcelVBAでキーボード方向キーを押したら塗りつぶしセルを移動する方法
Wendy02の回答
- Wendy02
- ベストアンサー率57% (3570/6232)
ご質問のコードは、イベントの一種で、プロ用のコードです。失礼ですが、前回の質問内容から、そのコードを扱うような方には見えないのですが。 Win32 API関数などには、PrivateやPablic などのステートメントを入れたほうが良いですし、意図的にしているなら別ですが、ColorIndex = 0 や2バイトの変数は関心しません。 私の記憶だけですが、GetAsyncKeyState(37) = 0 は、キーが押されていないという意味ですが、逆に[→]キー以外を押しているという意味にもなりますから、このキーを監視し続けても、解放されないはずです。もちろん、元のコードは、イベントの一種ですから、無限ループが発生させますが、それを利用するなら、RaiseEvent やWin32 API関数のタイマー処理で、イベントの監視が必要なはずです。ここの掲示板では、そのような内容は私にとっても敷居が高いです。RaiseEvent ならともかく、Do ～ Loop型のイベントは、、私はもう何年も作ったことがありません。 もう少しレベルを下げて作ってみました。なお、ActiveCell は、どこにあっても、関係がありません。 '// 'シートモジュール Private Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long Private Const VK_LEFT = &H25 '[←] 37 Private Const VK_UP = &H26 '[↑] 38 Private Const VK_RIGHT = &H27 '[→] 39 Private Const VK_DOWN = &H28 '[↓] 40 Private PArea As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) Const mCOLOR As Integer = 3 If PArea Is Nothing Then '初期化 Me.UsedRange.Interior.ColorIndex = xlColorIndexNone Set PArea = Range("B2:C2") End If If GetAsyncKeyState(VK_LEFT) <> 0 Then If PArea.Cells(1).Column = 1 Then Exit Sub PArea.Interior.ColorIndex = xlColorIndexNone Set PArea = PArea.Offset(0, -1) APaint PArea, mCOLOR ElseIf GetAsyncKeyState(VK_UP) <> 0 Then If PArea.Cells(1).Row = 1 Then Exit Sub PArea.Interior.ColorIndex = xlColorIndexNone Set PArea = PArea.Offset(-1, 0) APaint PArea, mCOLOR ElseIf GetAsyncKeyState(VK_RIGHT) <> 0 Then If PArea.Cells(PArea.Cells.Count).Column = Columns.Count Then Exit Sub PArea.Interior.ColorIndex = xlColorIndexNone Set PArea = PArea.Offset(0, 1) APaint PArea, mCOLOR ElseIf GetAsyncKeyState(VK_DOWN) <> 0 Then If PArea.Cells(PArea.Cells.Count).Row = Rows.Count Then Exit Sub PArea.Interior.ColorIndex = xlColorIndexNone Set PArea = PArea.Offset(1, 0) APaint PArea, mCOLOR End If End Sub Private Sub APaint(rng As Range, clIdx As Integer) With rng .Interior.ColorIndex = xlColorIndexNone .Interior.ColorIndex = clIdx End With End Sub
関連するQ&A
- 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
- 締切済み
- Visual Basic
- 押されているキーの評価について
Excel2002のVBAです。 次のコードで押されたキーを判別していますが、Altの時だけ、 キーを離なしても、離したあと1度だけ、押されていると評価 されてしまいます。 これは回避できないのでしょうか? '--------------------------- Declare Function GetAsyncKeyState Lib "user32.dll" _ (ByVal vKey As Long) As Long '--------------------------- Private Sub CommandButton1_Click() If GetAsyncKeyState(vbKeyControl) <> 0 Then MsgBox "CTRLキーを押しながらクリックされました。" End If If GetAsyncKeyState(vbKeyShift) <> 0 Then MsgBox "Shiftキーを押しながらクリックされました。" End If If GetAsyncKeyState(vbKeyMenu) <> 0 Then MsgBox "Altキーを押しながらクリックされました。" End If End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBA セルの入力後「Delete」キーを押したか判断するプログラム
セルに入力したあとその入力したキーが「Delete」キーかどうか判定するプログラムを作りたいのですが、下記のようにコードを書きました。 '標準モジュール Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long 'Microsoft Excel Objects（ワークシート） Private Sub Worksheet_Change(ByVal Target As Range) If GetAsyncKeyState(46) <> 0 Then 'キーボードの「Delete」キーかどうか判定 ○○ Else ○○ End If End Sub ところが、「Delete」キーを押してもGetAsyncKeyState(46)の値が「0」になり、「Delete」キーを押してないことになってしまいます。どのようにすればよいのでしょうか？ 回答よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- VBAのキー入力待ちでCPU負荷大
VBAでキー入力待ちで動作をするプログラムを組んでいますが、 プログラムの組み方が悪くCPUの負荷が高くなり、CPUの温度が かなり上がってしまいます。 いろいろ調べたのですがわかりません。 負荷を下げるプログラムの書き方を教えていただけないでしょうか。 Excel2010です。 よろしくお願いします。 Sub ボタン1_Click() Dim i, j, k, Maxrow, Colst, colen, nCnt As Integer Do Until GetAsyncKeyState(27) If GetAsyncKeyState(75) <> 0 Then ・ ・ 「モジュールプログラム1」 ・ ・ Do Until GetAsyncKeyState(75) = 0 Loop ElseIf GetAsyncKeyState(77) <> 0 Then ・ ・ 「モジュールプログラム2」 ・ ・ Do Until GetAsyncKeyState(77) = 0 Loop ElseIf GetAsyncKeyState(37) <> 0 Then If ActiveCell.Column > 1 Then ActiveCell.Offset(0, -1).Activate End If ElseIf GetAsyncKeyState(38) <> 0 Then If ActiveCell.Row > 1 Then ActiveCell.Offset(-1, 0).Activate End If ElseIf GetAsyncKeyState(39) <> 0 Then ActiveCell.Offset(0, 1).Activate ElseIf GetAsyncKeyState(40) <> 0 Then ActiveCell.Offset(1, 0).Activate End If For k = 1 To 300: Next k Loop Sheets("Main").Activate End Sub
- ベストアンサー
- Visual Basic
- エクセルVBA 前回のご回答で質問です
http://oshiete1.goo.ne.jp/qa3764996.html 前回上の質問をさせていただき、お二方から大変よいご回答をいただきました。 これを勉強したいと思い、読み取ろうとしたのですが、理解できないところがあり、日本語にすればどのようになるのかお教えいただきたいと思い、質問にまた参りました。分からないところは、下の全コード中の、 r.Offset(0, -1).Resize(1, 2).Interior.ColorIndex = trg.Interior.ColorIndex ' r.Offset(0, -1).Resize(1, 2).Font.ColorIndex = trg.Font.ColorIndex の部分です。OffsetとResizeでの行、列の方向性が理解できないのです。よろしければコメントを着けていただければ助かります。 よろしくお願いします。 Sub Macro1() Dim r, trg As Range For Each r In Range("B4:AD27") If r.Value <> "" Then Set trg = Range("B1:O1").Find(what:=r.Value, LookIn:=xlValues, lookat:=xlWhole) If Not trg Is Nothing Then r.Offset(0, -1).Resize(1, 2).Interior.ColorIndex = trg.Interior.ColorIndex ' r.Offset(0, -1).Resize(1, 2).Font.ColorIndex = trg.Font.ColorIndex End If End If Next r End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル ＶＢＡ セルの色をSheet1とSheet2の両方を変えたいのですが・・・
最近困っているところが表題の通りなのですが Sheet1のＢ２を右クリックするとＢ２のセルの色を変えて Sheet2のＢ２のセルも色を変えたいというものです。 現状で Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Dim Rng As Range, myRng As Range Dim RngA As Range, myRngA As Range Set Rng = Range("B3:W3,b7:w8,b12:w12,d13:w13,d17:w18,d22:w23") Set myRng = Intersect(Target, Rng) If myRng.Interior.ColorIndex = xlColorIndexNone Then myRng.Interior.ColorIndex = 37 Else If myRng.Interior.ColorIndex = 37 Then myRng.Interior.ColorIndex = 45 Else myRng.Interior.ColorIndex = xlColorIndexNone End If End If Cancel = True End Sub とここまではあるのですが、これをどう改造すればSheet2の同じセルの色もかわるのでしょうか？ 宜しくお願いいたします
- ベストアンサー
- オフィス系ソフト
- 【ExcelVBA】セルに入力された値によって書式を変更する
こんにちは。いつもお世話になっております。 標題の件で質問させて下さい。 セルに入力された値によって塗りつぶす色を変えるマクロを作成しています。 条件付き書式では、条件を3つしか指定できなかったので、マクロにて制御しようと思いました。 値の判定を行い、入力した各文字列の色で塗りつぶされるところは正常に動作しているのですが、 値が入っていてもいなくても、複数のセルを選択し、「Delete」キーを押下すると、背景色がグレーになってしまうのです。 初歩的な質問で申し訳ありませんが、どなたか上記のような動作をする理由をご教授頂けないでしょうか。 以下にソースを載せておきます。 宜しくお願い致します。 --- Private Sub Worksheet_Change(ByVal target As Range) On Error Resume Next If (target.Cells.Value = "グレー") Then target.Cells.Interior.ColorIndex = 15 ElseIf (target.Cells.Value = "イエロー") Then target.Cells.Interior.ColorIndex = 6 ElseIf (target.Cells.Value = "スカイブルー") Then target.Cells.Interior.ColorIndex = 33 ElseIf (target.Cells.Value = "ピンク") Then target.Cells.Interior.ColorIndex = 7 Else target.Cells.Interior.ColorIndex = 0 End If End Sub
- ベストアンサー
- その他（プログラミング・開発）
- ExcelVBAで、選択範囲内で同じ値が入力されたセルを調べる
選択範囲内（縦一列）で同じ値が入力されたセルの色を黄色にするプログラムを作りました。 Sub 選択範囲内で同じ値が入力されたセルを調べる_縦() Dim startrow As Byte Dim lasrow As Byte Dim i As Long Dim j As Byte Dim atai If TypeName(Selection) <> "Range" Then Exit Sub startrow = ActiveCell.Row '最初のセルの列番号を取得 lasrow = Selection.Rows(Selection.Rows.Count).Row '最終列番号を取得 '同じ値が入力されているセルを黄色にする For i = startrow To lasrow - 1 If ActiveSheet.Cells(i, ActiveCell.Column).Interior.ColorIndex = xlNone Then atai = ActiveSheet.Cells(i, ActiveCell.Column).Value For j = i + 1 To lasrow If atai = ActiveSheet.Cells(j, ActiveCell.Column).Value Then ActiveSheet.Cells(i, ActiveCell.Column).Interior.ColorIndex = 6 ActiveSheet.Cells(j, ActiveCell.Column).Interior.ColorIndex = 6 End If Next End If Next End Sub 但し、上記のプログラムでは選択範囲内に結合セルがあるとエラーになってしまいます。 どなたか、解決方法をご教授頂けませんでしょうか？ 宜しくお願い致しますm(._.)m
- ベストアンサー
- Visual Basic
- 空白セルと０値を識別させたい。（VBA）
すみません、誰か教えていただけますか。 シートの53、54、55行目にそれぞれ値入っています。 それを３行目にビジュアル的に表現させています。 55行目はセルの色で、53行目は数値があり同じ値が 続く部分の合計を出しています。 しかし、下記の記述ですと数値が0（変数D=0）の時に うまくいきません。空白セルと認識されてしまうと思います。 何か、良い方法があれば教えて頂けませんでしょうか。 宜しくお願いします。 Sub 表示() Dim a As Long Dim c As Long Dim D As Long Dim e As String Dim f As String c = 3 For a = 3 To 64 With Worksheets("Sheet1") If .Cells(53, a) <> .Cells(53, a + 1) Then .Range(.Cells(53, c), .Cells(53, a)).Select D = WorksheetFunction.Sum(Selection) e = D f = Selection(1).Offset(1, 0).Value G = Selection(1).Offset(2, 0).Value If D <> 0 Then Selection(1).Offset(-50, 0).Value = f + "//" + e .Range(.Cells(53, c), .Cells(53, a)).Offset(-50, 0).Select Selection.Interior.ColorIndex = G End If If Selection(1).Value = "" Then .Range(.Cells(53, c), .Cells(53, a)).Offset(-50, 0).Select Selection.ClearContents Selection.Interior.ColorIndex = xlNone End If c = a + 1 End If End With Next End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルの簡単なマクロ機能を追加したいのです
既存のエクセルマクロ（Sub チェック()以下です）に下記の内容のマクロを付け足したいです。 教えていただけないでしょうか。 付け足したい条件です： Sheet2のC列に 0 があれば Sheet1のB列に 愛 と（[太字]でセルの背景色を[灰色25%]にして）入れたいです 恐れ入りますがご存じの方がいらっしゃりましたら教えていただきたく何卒よろしくお願いいたします。 ----------------------------------------------- Sub チェック() Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim myRange1 As Range Dim myRange2 As Range Dim c1 As Range Dim c2 As Range Dim myCt As Long Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp)) Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp)) For Each c1 In myRange1 myCt = 0 For Each c2 In myRange2 If c2.Value = c1.Value Then If c2.Offset(, 1).Value = "" Then c1.Offset(, 1).Interior.ColorIndex = 3 Else c1.Offset(, 1).Value = c2.Offset(, 1).Value End If myCt = myCt + 1 End If Next c2 If myCt > 1 Then c1.Offset(, 1).Interior.ColorIndex = 10 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub
- 締切済み
- その他MS Office製品