Excel2010 セルをワンクリックで・・・

質問

いろいろネットで調べていますがピッタリのがありません。できるかどうかわからないのですが、ワンクリックで、セルに×が入力するようにしたいのですが。また、印刷するときは必要ないので、印刷前に一括で削除を考えています。×の個数は横一カ月のカレンダーに、縦10行内に３０か所くらいあります。できますでしょうか。

回答No.12

tom04 · ベストアンサー

一括消去は
「×」だけで他のデータはそのまま残さないといけない訳ですね？

Sub 一括消去()
Dim c As Range
For Each c In Range("D32:AH49,D52:AH60")
If c = "×" Then
c.ClearContents
End If
Next c
End Sub

にしてみてください。

何とか完成に近づいたでしょうか？m(_ _)m

お礼

ずうずしいお願いにご協力いただきましてありがとうございました。これからもよろしくお願いします。

補足

×印をクリックで表示するのは完成しました。長々とお付き合いいただきましてありがとうございました。
おいおい、プロシージャを解析して理解するようにします。表そのものはまだ完成していないので、何かありましたらこれからもよろしくお願いします。

回答No.11

tom04

親の仇のように顔をだします。

＞一か所ずつ表示していく方法ができませんが・・・

の件を見逃していました。

一つのSheetで二つのダブルクリックによるマクロ実行は同居できませんので、
一案として右クリックの操作を追加してみてはどうでしょうか？

一か所ずつ表示・消去を　右クリックとしてみました。
すでにコードが記載してあるVBE画面に↓のコードを追加してみてください。

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Application.Intersect(Target, Range("D38:AH43,D52:AH60")) Is Nothing Then Exit Sub
Cancel = True
If Target = "" Then
Target = "×"
Else
Target = ""
End If
End Sub

これで前回のダブルクリック・一括消去も生きて、なおかつ右クリックで1セルずつの表示・消去が可能になると思います。

※　通常、右クリックはショートカットメニューの表示になりますがその機能は使用できません。

今回も外していたらごめんなさいね。m(_ _)m

補足

何回も回答いただきましてご足労をおかけします。

右クリックで１個ずつの表示はできます。これで、ダブルクリックで３か所同時表示と合わせてできるようになりました。

しかし、マクロの一括消去で×印は消去できるのですが、その範囲に入っていたデータもすべて消去されます。

尚、範囲は３文字同時が("D38:AH43,D52:AH60")
１セルずつが("D32:AH49,D52:AH60")
です。修正してＯＫです。

回答No.10

tom04

またまた参上です！
この際ですので、とことん付き合っちゃいます！

前回1行ずつ抜けているなぁ～！っと思いながらコードを記載していました。
↓の画像のような範囲での各色分けのグループでよい訳ですよね？

今までのコードはすべて無視して↓のコードにしてみてください。
（今回もダブルクリックです）
補足にある
＞(D39,D41,D42)は
＞(D39,D41,D43)　というグループにしています。

尚、「範囲内にプルダウン等でデータ入力がある」といった内容の記憶がありますので、
仮に範囲内にデータがある場合はそのデータを消さないようにしてみました。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim myArea As Range
Dim myArray As Variant
Dim myFlg As Boolean
Dim i As Long
Dim j As Long
Dim k As Long

Set myArea = Range("D38:AH43,D52:AH60")
If Application.Intersect(Target, myArea) Is Nothing Then Exit Sub
Cancel = True
i = Target.Row
j = Target.Column
Select Case i
Case 38, 40, 42
myArray = Array(38, 40, 42)
Case 39, 41, 43
myArray = Array(39, 41, 43)
Case 52, 55, 58
myArray = Array(52, 55, 58)
Case 53, 56, 59
myArray = Array(53, 56, 59)
Case Else
myArray = Array(54, 57, 60)
End Select
myFlg = False
For k = 0 To 2
If Cells(myArray(k), j) = "×" Then
myFlg = True
Exit For
End If
Next k

For k = 0 To 2
If myFlg = False Then
If Cells(myArray(k), j) = "" Then
Cells(myArray(k), j) = "×"
End If
Else
If Cells(myArray(k), j) = "×" Then
Cells(myArray(k), j) = ""
End If
End If
Next k
End Sub

Sub 一括消去()
Range("D38:AH43,D52:AH60").ClearContents
End Sub

こんなんではどうでしょうか？
何とかご希望通りになればよいのですが・・・m(_ _)m

補足

回答ありがとうございます。

３か所同時×印表示は希望通りです。AH60の追加も確認しました。ありがとうございます。

ANo.９の補足にも記載しておりますが、1か所ずつ表示していく方法ができませんが、この記述に記載されているのでしょうか。それとも、最初の回答で戴いた記述に追加するのでしょうか。これはやってみたのですがうまくいきません。

要求ばかりで大変申し訳ございませんがご教授戴けると幸いです。

回答No.9

tom04

ほんとぉ～っに！何度もごめんなさい。

No7・8は無視してください。

↓に再訂正お願いします。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim myArea As Range
Dim myArray As Variant
Dim myFlg As Boolean
Dim i As Long
Dim j As Long
Dim k As Long
Set myArea = Range("D38:AH43,D52:AH53,D55:AH56,D58:AH59")
If Intersect(Target, myArea) Is Nothing Then Exit Sub
Cancel = True
i = Target.Row
j = Target.Column
Select Case i
Case 38, 40, 42
myArray = Array(38, 40, 42)
Case 39, 41, 43
myArray = Array(39, 41, 43)
Case 52, 55, 58
myArray = Array(52, 55, 58)
Case Else
myArray = Array(53, 56, 59)
End Select
myFlg = False
For k = 0 To 2
If Cells(myArray(k), j) = "×" Then
myFlg = True
Exit For
End If
Next k
For k = 0 To 2
If Cells(myArray(k), j) = "" Then
Cells(myArray(k), j) = "×"
Else
Cells(myArray(k), j) = ""
End If
Next k
End Sub

※　慌てて投稿すると、良くないですね。
※　もっと簡単になるかもしれません。

この質問ページを何度も汚してごめんなさいね。m（_ _）m

お礼

回答ありがとうございます。

補足

回答ありがとうございます。返事が遅れまして申し訳ありません。

３か所同時入力試しました。希望通りですが、(D38,D40,D42)、(D39,D41,D42)、(D52,D55,D58)、(D53,D56,D59)、(D54,D57,D60)の(D54,D57,D60)グループが抜けているので、いろいろトライしましたがうまくいません。
また、最初に回答いただいた、一か所入力する記述の、一括消去の後に、この３か所同時入力方式を追加しましたがうまくいきません。それぞれ単独では機能を発揮しているのですが、併せてた機能を利用したいですが。よろしくお願いします。

回答No.8

tom04

何度もごめんなさい。

前回投稿したコードを投稿後、客観的に見てみると、
何度も同じ記載をして、無駄なコードだと反省しています。

No.7の動作でよいのであれば、もっと簡潔にできます。

↓のコードに訂正してください。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim myArea As Range
Dim myArray As Variant
Dim myFlg As Boolean
Dim i As Long
Dim j As Long
Dim k As Long
Set myArea = Range("D38:AH43,D52:AH53,D55:AH56,D58:AH59")
If Intersect(Target, myArea) Is Nothing Then Exit Sub
Cancel = True
i = Target.Row
j = Target.Column
Select Case i
Case 38, 40, 42
myArray = Array(38, 40, 42)
Case 39, 41, 43
myArray = Array(39, 41, 43)
Case 52, 55, 58
myArray = Array(52, 55, 58)
Case Else
myArray = Array(53, 56, 59)
End Select
For k = 0 To 2
myFlg = False
If Cells(myArray(k), j) = "×" Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
For k = 0 To 2
Cells(myArray(k), j) = "×"
Next k
Else
For k = 0 To 2
Cells(myArray(k), j) = ""
Next k
End If
End Sub

これで前回と同じ動きになると思います。

じっくり考えればもっと良い方法があるかもしれません。
どうも失礼しました。m（_ _）m

補足

回答ありがとうございます。

(D38,D40,D42)、(D39,D41,D42)、(D52,D55,D58)、(D53,D56,D59)、(D54,D57,D60)

の(D54,D57,D60)グループが抜けているようですが、追加してトライしてみます。

回答No.7

tom04

No.1・2・4です。

結構ややこしくなってしまいましたね！
面白そうなのでちょっとチャレンジしてみました。

今回はダブルクリックでの方法です。

↓の画像のような色分けでグループになっている訳ですね？
そしてどこのセルをダブルクリックしても同色のセルに「×」が入ったり、「×」が消えたり！
という感じにしています。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim myArea As Range
Dim myRange As Range
Dim myArray As Variant
Dim myFlg As Boolean
Dim i As Long
Dim j As Long
Dim k As Long
Set myArea = Range("D38:AH43,D52:AH53,D55:AH56,D58:AH59")
If Intersect(Target, myArea) Is Nothing Then Exit Sub
Cancel = True
i = Target.Row
j = Target.Column
Select Case i
Case 38, 40, 42
myArray = Array(38, 40, 42)
For k = 0 To 2
myFlg = False
If Cells(myArray(k), j) = "×" Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
For k = 0 To 2
Cells(myArray(k), j) = "×"
Next k
Else
For k = 0 To 2
Cells(myArray(k), j) = ""
Next k
End If
Case 39, 41, 43
myArray = Array(39, 41, 43)
For k = 0 To 2
myFlg = False
If Cells(myArray(k), j) = "×" Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
For k = 0 To 2
Cells(myArray(k), j) = "×"
Next k
Else
For k = 0 To 2
Cells(myArray(k), j) = ""
Next k
End If
Case 52, 55, 58
myArray = Array(52, 55, 58)
For k = 0 To 2
myFlg = False
If Cells(myArray(k), j) = "×" Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
For k = 0 To 2
Cells(myArray(k), j) = "×"
Next k
Else
For k = 0 To 2
Cells(myArray(k), j) = ""
Next k
End If
Case Else
myArray = Array(53, 56, 59)
For k = 0 To 2
myFlg = False
If Cells(myArray(k), j) = "×" Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
For k = 0 To 2
Cells(myArray(k), j) = "×"
Next k
Else
For k = 0 To 2
Cells(myArray(k), j) = ""
Next k
End If
End Select
End Sub

Sub 一括消去()
Dim myArea As Range
Set myArea = Range("D38:AH43,D52:AH53,D55:AH56,D58:AH59")
myArea.ClearContents
End Sub

じっくり考えればもっと良い方法があると思います。
とりあえずはこの程度で・・・m(_ _)m

回答No.6

tsubuyuki

> 具体的には、(D38,D40,D42)、(D39,D41,D42)、(D52,D55,D58)、(D53,D56,D59)、(D54,D57,D60)のグループです。D38をクリックするとD40,D42、若しくは、D40またはD42をクリックすると、D38,D42若しくは、D38,D40に×を表示させたいと思っています。

これに対してうまい処理が思いつかないので、口を出さないつもりだったのですが＾＾；

・・・気を取り直して。
とりあえず、シングルクリックはうまくない処理だと気づいていただけたようで何よりです。
SelectionChangeは読んで字のごとく「選択セルが変わったら」のタイミングですから
キーボードのカーソルキーで動かしても「選択セルが変わる」ことになるので
このマクロが動いてしまうというカラクリです。

個人的にはダブルクリックもあまりおすすめしません。
ご存じの通り、通常の場合は「ダブルクリック＝セル内編集」ですから、
これもまた何か支障が出る可能性は否定できません。
おそらく「×」がセル内に表示されたうえで編集状態になるでしょう。
なんでもかんでもダブルクリックしてしまう癖がある方は意外と多いので、
これが新たな混乱を招かないとは言い切れません。
不要なところまで×に書き換わってしまう可能性は大いにあります。
（もちろん、回避は不可能ではありませんが。）

さらに言うと、
> その範囲はプルダウンリストで入力するところ
とのことですが、入力規則・リストでの設定でしょうか。
そのリストに「×」は含めていますか？
もしくは、リスト外の値を許可する設定にしていますか？
このどちらかをしていないと、いちいち警告が出て、かえってややこしくなりそうです。

私個人的にはやはり、面倒でも「×」をつけたいところにフォーカスを持って行き、
別途用意したボタンを押すと「×」がつくやりかたです。
サンプルは「選択されたセル内にぴったり収まる“×”のようなオートシェイプを描く」マクロです。

Sub Macro1()
　Dim myRange As Range
　Set myRange = Selection

　With Selection
　　ActiveSheet.Shapes.AddShape(msoShapeMathMultiply, _
　　　　　　　　.Left, .Top, .Width, .Height).Select
　End With

　With Selection
　　With .ShapeRange
　　　.Fill.ForeColor.RGB = RGB(0, 0, 0)
　　　.Line.Visible = msoFalse
　　End With
　　.PrintObject = msoFalse
　End With

　myRange.Select
End Sub

考えられる利点は
・「×」を置いてもセルの内容は書き換わらない
・「入力規則」に抵触しない
・「オブジェクトを印刷しない」設定を採用しているので、
　　> 印刷するときは必要ないので、印刷前に一括で削除
　この作業の手間が不要
大まかに考えてこの３点です。
もう一つあるとしたら、「範囲に関係なく×をつけられる」と言うことでしょうか。
今回はコレがデメリットになる可能性もありますが＾＾；
ちなみに間違って置いてしまったら、選択してDeleteキーで消えます。

ご希望の処理からは外れるかもしれません。
考え方として、こんなやり方もあるかもしれない、程度にお納めくださいませ。

お礼

丁寧な解説つきでありがとうございました。今後もよろしくお願いします。

補足

回答ありがとうございます。返事が遅れて申し訳ありません。
いろいろとご検討ありがとうございます。

他への影響を考慮してのご提案だと思いますが、３０～４０ほどを、いっきに挿入していくのでなるべく、操作が簡単な方が効率よいかと考えています。

ご教授いただいた記述を試してみましたが、

>私個人的にはやはり、面倒でも「×」をつけたいところにフォーカスを持って行き、別途用意したボタンを押すと「×」がつくやりかたです。

「フォーカスを合わせてボタンを・・・」が効率を悪いかと考えます。
tom04さんの方式を取り入れ、問題があるようですと参考にさせていただきます。
丁寧な回答ありがとうございました。今後もよろしくお願いします。

回答No.5

tsubuyuki

「当初の目的は達成されたようで」何よりです。
が、ちょっとだけ横から口を出させていただきます。

これ、どうしても“ワンクリック”にこだわりますか？
みなさん提示されているように、“ワンクリックで”にこだわると、
どうしてもWorksheet_SelectionChangeのタイミングしかないのですが、
これだと「範囲内をキーボードの矢印キーで移動する度」に
×がついたり消えたりしちゃいますが、それで本当に大丈夫なのでしょうか？
> 操作する人はExcelに詳しくなく、
という事であれば、なおさら混乱するのではないだろうか？と心配です。

余計なお世話なのかもしれませんが、
もう少しよく考えてから実装された方が良いかもしれませんね。

お礼

丁寧な回答ありがとうございました。今後もよろしくお願いします。

補足

ご指摘ありがとうございます。tom04さんもご心配されておりました。効率を考えワンクリックの方が効率が良いと思いましたが、実際にワンクリックが出来上がり確認すると、ご心配が的中です。なぜなら、その範囲はプルダウンリストで入力するところなのでプルダウンリストを出すためにクリックすると×がでて、その後にリストから選択した文字が表示されるのがわかりました。また、ご指摘の矢印も確認したところ×の表示が移動していくことがわかりました。
最初にダブルクリックの記述をご教授戴いているので変更する予定です。

回答No.4

tom04

No.1・2です。

補足を読ませていただいて・・・
（ワンクリックにしています）

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.Intersect(Target, Range("D32:AH49,D52:AH60")) Is Nothing Then Exit Sub
If Target = "" Then
Target = "×"
Else
Target = ""
End If
End Sub

Sub 一括消去()
Range("D32:AH49,D52:AH60").ClearContents
End Sub

こんなんではどうでしょうか？

※　エラーが出続けるようであれば、
すべてのコードを一旦削除してあらたにコードを入力していてください。m（_ _）m

補足

返事が遅れまして申し訳ありません。ワンクリックできました。ありがとうございます。ご面倒おかけしました。

ご面倒おかけついでにもう一つ悩んでいます。
この×のワンクリック入力ですが、この範囲内("D32:AH49,D52:AH60")に飛び飛びに同じ目的のセルがあります。最初は一つずつクリックして入力しようと思っていましたが、tom04さんの豊富な知識をお借りして、一回のクリックで他２か所のセルに×を表示することです。

具体的には、(D38,D40,D42)、(D39,D41,D42)、(D52,D55,D58)、(D53,D56,D59)、(D54,D57,D60)のグループです。D38をクリックするとD40,D42、若しくは、D40またはD42をクリックすると、D38,D42若しくは、D38,D40に×を表示させたいと思っています。

要は、３つの空白のうちどれか一つをクリックすると、他の２か所の空白セルに×が入力されるわけです。すでに３か所のうちにどれか×が入力されていても残りの空白セルに×を表示させます。

その他のグループも同じです。説明では、D列だけ説明していますが、それぞれのグループAH列まで続いています。

よろしくお願いします。

回答No.3

okormazd

シングルクリックでやりたいなら、次のようにでもする。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Set myrange = Range("$B$2:$E$10")
Set isect = Application.Intersect(Target, myrange)

If isect Is Nothing Then Exit Sub
If Range("$A$1") = "×" Then
isect.Value = "×"
End If

End Sub
1つ開いているセルにデータがあるかないかで処理を分けている。
ここでは、$A$1が"×"だったら"×"を書くようにしたが、どこでも邪魔にならないところでいいし、"×"じゃ無くても何でも好きなものでいい。"1"ならとしたほうが簡単。セル範囲でも対応している。

一括で削除は、クイックアクセスツールバーに、「すべてクリア」のボタンを出しておけば、選択してそのボタンでいいように思うが、"×"だけクリアする次でもいい。

Sub x_clear()

Set myrange = Range("$B$2:$E$10")

For Each c In myrange
If c.Value = "×" Then
c.Value = ""
End If
Next

End Sub

お礼

回答ありがとうございました。今後もよろしくお願いします。

補足

回答ありがとうございます。
×を入れるセルは規則性がなく任意のセルになり次の範囲です。
("D32:AH49,D52:AH60")
「一括削除」は操作する人はExcelに詳しくなく、なるべくリボン操作はしないように設計しています。提案ありがとうございます。
回答の式を挿入して確認しましたが、「コンパイルエラー」変数が定義されていません。となります。

回答No.2

tom04

No.1です。

＞まとめてクリックする数が多いので、願わくばワンクリックにしたいところですが

に関しては、
1行目の
＞Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
を
＞Private Sub Worksheet_SelectionChange(ByVal Target As Range)

に変更すれば可能です。
しかし、これはあまりオススメしません。
仮に入っている「×」を消したい場合はいったん別セルを選択しそのセルを選択し直さなければいけません。

敢えてやるとすると右クリックですかね？
その場合は

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("A1:AE10")) Is Nothing Then Exit Sub
If Target = "" Then
Target = "×"
Else
Target = ""
End If
Cancel = True
End Sub

こんな感じでしょうかね。m(_ _)m

お礼

回答ありがとうございます。

補足

回答ありがとうございます。

×を入れるセルは規則性がなく任意のセルになり次の範囲です。
("D32:AH49,D52:AH60")

ワンクリックの回答式を挿入して確認しましたが、「コンパイルエラー」変数が定義されていません。となります。よろしくお願いします。