VBA|楕円のリンクについて

質問

いつもお世話になります。
エクセルは2010を使っています。

現在、エクセルで表を作成しています。
表内の一部分に「該当する」「該当しない」の２つの項目があり
どちらかに楕円を描かないといけません。
楕円は、「挿入」→「図形」から楕円を描いています。

また、表は3枚複写で、「シート１」「シート２」「シート３」に
それぞれ「該当する」「該当しない」の項目があります。

シート１の「該当する」に楕円を入れる場合、残りのシート２、シート３も「該当する」に楕円が必要になります。

シート１の「該当しない」に楕円を入れる場合、残りのシート２、シート３も「該当しない」に楕円が必要になります。

現在は、シート１、シート２，シート３の「該当する」「該当しない」両方にとりあえず楕円を入れています。
そして、「該当する」に楕円が必要な場合、シート１，シート２、シート３の「該当しない」の楕円を削除。
「該当しない」に楕円が必要な場合、シート１、シート２、シート３の「該当する」の楕円を削除――というふうにしています。

それ以外の、たとえば、「住所」や「名前」といった入力欄には、シート１に入力したら、シート２、シート３にもおなじ内容が入力されるようにリンクしています。

なので、今回の「該当する」「該当しない」の楕円の箇所の理想の状態は、最初は「該当する」「該当しない」どちらにも楕円が表示されていない状態で、「該当する」「該当しない」どちらかをクリック、もしくはダブルクリックすると、そこに楕円が表示されて、残りのシート２，シート３にも楕円が表示される――です。

このような動作をエクセルのVBAで可能でしょうか？

上記のような表で楕円を入れる場合、どのようにつくったら一番理想的なのか、皆様のお知恵をお借りしたいです。

どうか、よろしくお願いいたします。

回答No.1

mitarashi · ベストアンサー

理想的なんて言われると回答できませんが、徒然なるままに作成してみました。
楕円を描かせるのは簡単ですが、消したいという場合はやっかいです。
Sheet1のWクリックしたセルに楕円を描くと共に、左隣か右隣のセルに楕円があれば消してしまうというコードです。Sheet2,3についても同様に処理します。（Sheet1基準で)
実用には、イベントが動作するセルを制限する必要があるでしょう。興味を持たれたらご自分でお調べ下さい。
xl2010で試しています。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim myCell As Range
Dim shp As Shape

Cancel = True
If Target.Column > 1 Then
Set myCell = Target.Offset(0, -1)
If delOval(myCell) Then
delOval Sheets(2).Range(myCell.Address)
delOval Sheets(3).Range(myCell.Address)
End If
End If
If Target.Column < Me.Columns.Count Then
Set myCell = Target.Offset(0, 1)
If delOval(myCell) Then
delOval Sheets(2).Range(myCell.Address)
delOval Sheets(3).Range(myCell.Address)
End If
End If
addOval Target
addOval Sheets(2).Range(Target.Address)
addOval Sheets(3).Range(Target.Address)
End Sub

Private Sub addOval(targetRange As Range)
Dim myOval As Shape

With targetRange
Set myOval = .Parent.Shapes.AddShape(msoShapeOval, _
.Left + .Width * 0.1, .Top + .Height * 0.1, .Width * 0.8, .Height * 0.8)
End With
With myOval
.Fill.Visible = msoFalse
.Line.ForeColor.RGB = vbBlack
End With
End Sub

Private Function delOval(targetRange As Range) As Boolean
Dim shp As Shape

For Each shp In targetRange.Parent.Shapes
If Not Intersect(shp.TopLeftCell, targetRange) Is Nothing Then
shp.Delete
delOval = True
Exit Function
End If
Next shp
delOval = False
End Function

補足

mitarashiさまへ
ご回答いただきまして、ほんとうにありがとうございます。
また、下記の質問では、たいへんお世話になりました。
http://oshiete.goo.ne.jp/qa/8226147.html

mitarashiさんが作成されたコードですが、まさにわたしの求めている動作でした。

＞実用には、イベントが動作するセルを制限する必要があるでしょう。興味を持たれたらご自分でお調べ下さい。

こちらは上記のURLで教えていただいた
If Intersect(Target, Range("K66,R66")) Is Nothing = False Then
・
・
End If

を用いることで解決いたしました。
また、表示される楕円の線を少し細くしたいと思い、試行錯誤してみて
「.Line.Weight = 1」をつけることで解決しました。

ただ、3点ほどどうしても解決できないことがありますので、教えていただけますと幸いです。
(1)
「該当する」のセルと「該当しない」のセルの間に「・」のセルがありますので

Set myCell = Target.Offset(0, -1)
を
Set myCell = Target.Offset(0, -2)
に

Set myCell = Target.Offset(0, 1)
を
Set myCell = Target.Offset(0, 2)
に変更してみました。

結果
「該当しない」をダブルクリックして楕円を表示し、「該当する」をダブルクリックする場合はうまく動作するのですが
逆に「該当する」をダブルクリックして楕円を表示し、「該当しない」をダブルクリックした場合は「該当する」の楕円が消えてくれませんでした。

(2)
シート１では楕円はセル内に上下左右中央に表示されるのですが
シート２、シート３では「↓」のカーソルキーで約7回押したほど下に楕円が下がってしまいます。

ためしに、エクセルの「新規作成」でおなじ箇所におなじ数のセルを結合して試したところ
こちらではシート２、シート３もシート１とおなじ位置に楕円が表示され、正常でした。

(3)シート１、シート２は黒色の楕円でOKなのですが、シート３だけ楕円の色を「薄い青（標準の色の右から4番目）」にしたいです。

上記について教えていただけますと幸いです。

エクセルのデータ（注文書.xlsm）を下記URLにアップしてみましたので
(1)(2)の症状についてみていただけますと幸いです。

https://docs.google.com/file/d/0Bww4BczdsriGTEhmNEdFSVB5Nk0/edit?usp=sharing

回答No.7

mitarashi

mitarashiです。
今頃はお気づきになっているかもしれませんが、

完成の悦びを取り上げては申し訳ないと、考え方の提示に止めた、
delOval Sheets(2).Range(Target)
は、
delOval Sheets(2).Range(Target.Address)
の誤りです。
混乱させて申し訳ありません。
その分完成の悦びが増加したという事で、結果オーライですね。(^^;)

当方も質問者からスタートしたのですが、その内に一晩冷却期間をおくと、大抵のバグが自己解決できる事に気付き卒業しました。masarin16さんもじきにそのレベルに到達されると思いますので、是非VBAの沼にはまって下さい。

お礼

mitarashiさまへ
お返事が遅くなり、申し訳ございません。

mitarashiさんからご教授いただいた、「target」を「target.address」に
変更することで、動きました。
なので、現在はこちらに修正しています（^^）

＞当方も質問者からスタートしたのですが、その内に一晩冷却期間をおくと、大抵のバグが自己解決できる事に気付き卒業しました。masarin16さんもじきにそのレベルに到達されると思いますので、是非VBAの沼にはまって下さい。

そうなんですよね！
ほかのことにも言えるのですが、そのときはどんなにがんばってもできなかったことでも、いったん忘れて、次の日に見てみると、それまでは見えなかった部分が見えてくることってけっこうありますよね！

わたしの場合は、「target」は「target.address」でないとおかしいとわかるくらいにまでは、VBAの基礎を勉強するところからはじめないといけないかもしれませんね（汗）

早く、そのレベルまで到達できるように頑張ります！

それでは、なごり惜しいですが、これにて募集のほうを締め切りたいと思います。
いままで、ほんとうにありがとうございました。

回答No.6

mitarashi

mitarashiです。
masarin16さんが付け加えた下記コードで、一旦、Targetに楕円があれば削除し、シート２，３の当該位置の楕円を消す動作を行っているのです。そして、その後でまた同じ場所に楕円を描いています。という訳で解決まではあと少しでした。
Set myCell = Target.Offset(0, 0)

If delOval(myCell) Then
delOval Sheets(2).Range(myCell.Address)
delOval Sheets(3).Range(myCell.Address)
End If

ここではTarget.Offset(0, 0)はTargetと同じなので、myCellへの代入はやめてそのまま使い

If delOval(Target) Then
delOval Sheets(2).Range(Target)
delOval Sheets(3).Range(Target)
else
'Offset(0,2)およびOffset(0,-2)の楕円チェック～削除
If Target.Column > 2 Then．．．
'次いでTargetへの楕円描画
addOval Target．．．
End If

とすれば良いです。

お礼

mitarashiさまへ
とてもわかりやすく教えてくださり、ほんとうにありがとうございます。

＞masarin16さんが付け加えた下記コードで、一旦、Targetに楕円があれば削除し、シート２，３の当該位置の楕円を消す動作を行っているのです。そして、その後でまた同じ場所に楕円を描いています。という訳で解決まではあと少しでした。
mitarashiさんのおかげで、上記の解説もあって、書かれてあるコードからエクセルでどんなことがおこっているのか、頭の中でまだうっすらとですがイメージできました。

そして、結論から言いますと、「If～Else」のヒントもあり、下記コードに修正することで希望どおりダブルクリックで楕円を消すことができるようになりました！

希望どおり動くようになったときは、ものすごくうれしかったです。
----------------------------------------------------------------------------
If Intersect(Target, Range("M66,T66")) Is Nothing = False Then
Cancel = True
Set myCell = Target.Offset(0, 0)
If delOval(myCell) Then
delOval Sheets(2).Range(myCell.Address)
delOval Sheets(3).Range(myCell.Address)

Else

Set myCell = Target.Offset(0, -3)
If delOval(myCell) Then
delOval Sheets(2).Range(myCell.Address)
delOval Sheets(3).Range(myCell.Address)
End If
Set myCell = Target.Offset(0, 3)
If delOval(myCell) Then
delOval Sheets(2).Range(myCell.Address)
delOval Sheets(3).Range(myCell.Address)
End If
addOval Target
addOval Sheets(2).Range(Target.Address)
addOval Sheets(3).Range(Target.Address), RGB(0, 176, 240)

End If
End If
-----------------------------------------------------------------------------
ただ、mitarashiさんから教えていただいた
＞ここではTarget.Offset(0, 0)はTargetと同じなので、myCellへの代入はやめてそのまま使い
＞If delOval(Target) Then
＞delOval Sheets(2).Range(Target)
＞delOval Sheets(3).Range(Target)
＞else
より、上記の作成したコードを-------------------------------------------------------------------------
If Intersect(Target, Range("M66,T66")) Is Nothing = False Then

Cancel = True

If delOval(target) Then
delOval Sheets(2).Range(target)
delOval Sheets(3).Range(target)

Else

Set myCell = Target.Offset(0, -3)

If delOval(myCell) Then
delOval Sheets(2).Range(myCell.Address)
delOval Sheets(3).Range(myCell.Address)
End If

Set myCell = Target.Offset(0, 3)

If delOval(myCell) Then
delOval Sheets(2).Range(myCell.Address)
delOval Sheets(3).Range(myCell.Address)
End If

addOval Target
addOval Sheets(2).Range(Target.Address)
addOval Sheets(3).Range(Target.Address), RGB(0, 176, 240)

End If

End If
----------------------------------------------------------------------------------

と、最初はしていました。

３つ両どなりの楕円をダブルクリックする場合は、選択したセルの３つ前後の楕円が消えて
選択したセルに楕円が表示される――と正常に動くのですが、楕円があるセルをダブルクリックすると
-----------------------------------------------------------
実行時エラー’1004’：
アプリケーション定義またはオブジェクト定義のエラーです。
-----------------------------------------------------------
とエラーがでていました。

わたし自身、VBAの知識がほとんどないため、必要なコードがなかったり等、すごく初歩的なミスをしているのだと思います。

エラー後に「デバッグ」を押すと「delOval Sheets(2).Range(Target)」のところが黄色のハイライト表示されていました。
だめもとで「delOval Sheets(2).Range(myCell.Address)」に戻してみると、上記のエラーがでなかったので
とりあえずそれで進めてみて、IF～Elseに入れてみたところ、動作するようになりました。

これで100％わたしの希望していた動作をするようになりました。
これもmitarashiさんが数日間にわたり、ご教授してくださったおかげです。
ほんとうにありがとうございました。

回答No.5

mitarashi

mitarashiです。得意の対症療法ですが、下記をWorkbookモジュールに組み込むと、楕円描画時のエラーはなくなりました。
言わずもがなですが、1234のところは実際のPasswordと差し替えて下さい。完成後は世間様から見られないように、VBA Projectにも保護をかける必要がありますね。
#4ではCloseと書きましたが、標準モジュールの場合と混同しており、失礼いたしました。
Private Sub Workbook_Open()
Dim sh As Worksheet

For Each sh In ThisWorkbook.Worksheets
sh.Protect Password:="1234", UserInterfaceOnly:=True
Next sh
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim sh As Worksheet

For Each sh In ThisWorkbook.Worksheets
sh.Protect Password:="1234", UserInterfaceOnly:=True
Next sh
End Sub

補足

mitarashiさまへ

いつも迅速なご回答、ほんとうにありがとうございます。
mitarashiさんから教えていただいたコードをWorkbookモジュールに組み込むことで
あんなに悩んでいたエラーコードが出なくなり、正常に動作するようになりました。

VBA Projectは、mitarashiさんが言われたとおり、保護をかけました。

現在、動作に十分満足をしているのですが
セルに楕円をつけた後に楕円をつけたセルをダブルクリックすると、シート１、シート２、シート３の楕円が消えるようになると、もっと便利だと思い、コードをあれこれいじってみたのですが、できませんでした。

現在は、mitarashiさんから教えていただいたコードを元に

-----------------------------------------------------------------
Set myCell = Target.Offset(0, 0)

If delOval(myCell) Then
delOval Sheets(2).Range(myCell.Address)
delOval Sheets(3).Range(myCell.Address)
End If
------------------------------------------------------------------
というコードを追加して、おなじセルをダブルクリックするごとに楕円が増えるのを抑えているだけです。

コードを言葉で言うと
「もしも選択セルをダブルクリックしたときに楕円が存在していたら、その楕円を消去して、シート２、シート３にもおなじ処理をする」
となります。

それを、これまでいろいろ教えていただいたコードを元にIF文でわからないなりに書いてみたのですが、わたしにはまだ早かったようです。

教えていただけますと、幸いです。

回答No.4

mitarashi

mitarashiです
再現実験をしておりませんので、とりあえず一般的なアドバイスをしておきます。
ワークシートをコードでいじる前に保護を解除し、コードの最後で再度保護するか、UserInterfaceOnly:=Trueをお試し下さい。
http://officetanaka.net/excel/vba/sheet/sheet07.htm

UserInterfaceOnly:=Trueについては、リンク先の、
>なお注意しなければいけないのは．．．
にご注意下さい。Workbook_Openと同Closeの両方に入れておくと良い様です。

回答No.3

mitarashi

#1,2です。
確かにずれますね。
姑息な手ですが、ズーム倍率の問題なら裏で100%に戻してから描画すれば良いかもしれません。
.Placement = xlFreeFloatingは効果がない様でした。

Private Sub addOval(targetRange As Range, Optional shapeColor As Long)
Dim myOval As Shape
Dim currentzoom As Double
Dim currentSheet As Worksheet

Application.ScreenUpdating = False
Set currentSheet = ActiveSheet
targetRange.Parent.Activate
currentzoom = ActiveWindow.Zoom
ActiveWindow.Zoom = 100
With targetRange.Cells(1).MergeArea
Set myOval = .Parent.Shapes.AddShape(msoShapeOval, _
.Left + .Width * 0.1, .Top + .Height * 0.1, .Width * 0.8, .Height * 0.8)
End With
With myOval
' .Placement = xlFreeFloating '効果無し
.Fill.Visible = msoFalse
If IsMissing(shapeColor) Then
.Line.ForeColor.RGB = vbBlack
Else
.Line.ForeColor.RGB = shapeColor
End If
End With
ActiveWindow.Zoom = currentzoom
currentSheet.Activate
Application.ScreenUpdating = True
End Sub

補足

mitarashiさまへ
いつも親身に教えてくださり、ほんとうにありがとうございます。

おかげで、わたしの望んでいたとおりの動作ができるようになりました。

けれど、最後に「シートの保護」をしたときに、１つ問題が発生しました。

シートの保護をしていないときは問題なかったのですが
シート１、シート２、シート３に「シートの保護」をすると
下記のエラーが表示されるようになりました。

----------------------------------------
実行時エラー'1004'：
「指定された値は境界を超えています。」
----------------------------------------

シートの保護を解除すると、正常に戻ります。

シートの保護では、上から2番目の「ロックされていないセル範囲の選択」のみチェックをいれて

います。

楕円を表示させるセルは、セルの書式設定からロックのチェックを外しています。

ダブルクリックで表示される楕円の書式設定を見ますと
デフォルトで「ロック」にチェックが入ることがわかりました。

当初は、楕円にロックが入っているため、シートを保護したときに、ロックされている楕円をvba

で操作しようとしたため、上記のようなエラーがでるのかなと思っていました。

そこで、ロックの解除について調べ、いろいろ試行錯誤してみまして、結果
With myOval
' .Placement = xlFreeFloating '効果無し

の下に下記のコードを入力することで、楕円のロックを解除することはできました。

----------------
.Locked = False
----------------

これで上記のエラーはでなくなるのでは――と期待したのですが
残念なことにおなじエラーメッセージが表示され、変化ありませんでした。

シート１、シート２、シート３の「シートの保護」をするときに下から2番目にあります「オブジ

ェクトの編集」に３つのシートともチェックを入れると、正常に動作します。

ただ、「オブジェクトの編集」にチェックを入れた場合、シート１、シート２、シート３の楕円を選択できるというのは、まだ許容範囲なのですが、チェックマークのときにつくった、正方形の枠

や、3行にまたがる「(」なども選択できるようになってしまい、都合が悪いです。

ここをクリアできると、完成すると思われますので、ご教授のほど、どうかよろしくお願いいたします。

回答No.2

mitarashi

#1です。
まず、ファイルをダウンロードして確認や、他のサイトを見に行く事は行わない事にしておりますので、悪しからず。
書かれた内容を拝見すると、masarin16さんなら、ご自分で解決できると思います。

１，２についてですが、結合セルの事は失念しておりました。
１は当方では再現できませんでした。２については再現出来ないと思います。

http://okwave.jp/qa/q8226147.html
と同様の考え方ですが、
targetRange → targetRange.cells(1).MergeArea
に変更すれば、事態が変わるかもしれません。

３については、addOvalに引数を増やして色を渡してやれば良いでしょう。
「薄い青（標準の色の右から4番目）」というのは、ColorIndexのお話でもなさそうですし、分かりかねます。
以上を盛り込んで、addOvalを書き換えると、次の様になります。ちょっと凝ってOptional引数としてあります。
色を黒以外にしたいときは、
addOval Sheets(3).Range(Target.Address), RGB(&H33, &H66, &HFF)
の様にします。黒の時は従来通りセル範囲だけ渡します。

Private Sub addOval(targetRange As Range, Optional shapeColor As Long)
Dim myOval As Shape

With targetRange.Cells(1).MergeArea
Set myOval = .Parent.Shapes.AddShape(msoShapeOval, _
.Left + .Width * 0.1, .Top + .Height * 0.1, .Width * 0.8, .Height * 0.8)
End With
With myOval
.Fill.Visible = msoFalse
If IsMissing(shapeColor) Then
.Line.ForeColor.RGB = vbBlack
Else
.Line.ForeColor.RGB = shapeColor
End If
End With
End Sub

targetRange.cells(1).MergeAreaはdelOvalの方にも適用して下さい。
If Not Intersect(shp.TopLeftCell, targetRange.Cells(1).MergeArea) Is Nothing Then

補足

mitarashiさまへ

＞targetRange → targetRange.cells(1).MergeArea
＞に変更すれば、事態が変わるかもしれません。

おしえていただいたとおり変更したところ、(1)の不具合が見事に解決できました。
ありがとうございます。

色の変更につきましても、詳しく教えていただけましたので、無事できました。

また、今回のコードでは、たとえば、「該当する」をダブルクリックして楕円を表示し、再度「該当する」をダブルクリックしますと、無限に楕円ができていました。

そこで、試行錯誤しまして
Set myCell = Target.Offset(0, 0)

If delOval(myCell) Then
delOval Sheets(2).Range(myCell.Address)
delOval Sheets(3).Range(myCell.Address)
End If

とすることで、うまくいきました。

ただ、(2)についての楕円がずれるという現象がやはり現れます。

いろいろと試してみた結果、表示倍率によって極度に現れることがわかりました。

たとえば、シート１の表示倍率を100％、シート２の表示倍率を30％、シート３の表示倍率を400％とすると、顕著に表れるかもしれません。

そこで、いろいろと調べてみたところ、
.Placement = xlFreeFloating
というのが「セルにあわせて移動やサイズ変更をしない。」というコードみたいで、入れると解決できるかもしれません。

ただ、どこに入れていいのかが、まだわたしの力ではわからず、上記のコードをいろいろなところに入れてみたのですが、エラーとなりました。