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

Question

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

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

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

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

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

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

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

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

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

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

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

mitarashi · Accepted Answer

理想的なんて言われると回答できませんが、徒然なるままに作成してみました。
楕円を描かせるのは簡単ですが、消したいという場合はやっかいです。
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 · Answer

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

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

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

mitarashi · Answer

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 · Answer

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 · Answer

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

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

mitarashi · Answer

#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 · Answer

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

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

http://oshiete.goo.ne.jp/qa/8226147.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

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

理想的なんて言われると回答できませんが、徒然なるままに作成してみました。

この回答への補足

mitarashiです。

mitarashiです。

mitarashiです。

この回答への補足

mitarashiです

#1,2です。

この回答への補足

#1です。

この回答への補足

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング