Excel VBA トグルボタンで一定のセルへ楕円を書き込みしたり消したりしたいのですが

質問

Excel VBAの初心者です。Ｗｅｂ検索で同じ事例がないか検索をしてみましたが、２件程近いものがありましたので、それを参考に自力でやってみましたが、書き込みまではすんなりいきますが、トグルボタンをＯＦＦにした場合（消すという動作）がどうも旨くいきません。どなたか宜しくお願いします。
根本的にVBAのコードが全部理解出来ていないというレベルですので、その辺をお察しの上お願いします。
実施したい内容は以下の条件下で行いたいと思います。
(1)sheet１にトグルボタンを作成
(2)トグルボタンを押した時、sheet2の２箇所のセル(AJ3とCJ3)と、sheet3の２箇所のセル(AJ3とCJ3)に楕円（透明）を書き込む
(3)トグルボタンを押した時、トグルボタン自体の色を赤色に変更
(4)トグルボタンを戻した時、(2)の作成した楕円を消す。またトグルボタン自体の色を元の色に戻す。

回答No.5

noname#144013 · ベストアンサー

こんにちは。

楕円画像を消去する処理は以下の部分で行っています。
※#2のマクロソース内の楕円の描画or消去用の関数【OpeOval】より抜粋。

　　＜楕円図形の消去＞
　　===========================================
　　　'既存の楕円図形を消去
　　　For Each shp In sht.Shapes
　　　　　If shp.TopLeftCell.Address = _
　　　　　　 sht.Range(vCelAdrs(nCelCnt)).Address Then
　　　　　　　shp.Delete
　　　　　　　Exit For
　　　　　End If
　　　Next
　　===========================================

これは、対象セルに内接する図形オブジェクトを見つけて、その図形オブジェクト
の削除を行うものです。

セルに内接する図形オブジェクトを見つける方法は、
対象のワークシートにある全ての『図形オブジェクト』を順番に見ていき、
　　【図形の近接するセルアドレス】　と　【対象セルのセルアドレス】　の一致
を見て判定しています。
このとき、【図形の近接するセルアドレス】は、『単一セル』のアドレスになります。

従って、今回、【対象セルのセルアドレス】が結合されたセルアドレスに変わった
ことにより、アドレスが一致しなくなったため、消去もできない状況になっています。

これを回避するには、図形に近接するセルの検出方法を、アドレスの比較では
なく、別の方法にする必要があります。

その別の方法のひとつとして、
　　Application オブジェクトの Intersect メソッド
が利用できます。
これは、指定のセル範囲の中に、指定のセルがあるかどうかが判定できます。
※詳しくは、VBAのヘルプをご覧下さい。

下記に、この方法を使用した改造版のマクロを掲載致します。

#2のマクロからの変更部分は、楕円の描画or消去用の関数【OpeOval】のみ
ですので、その関数のコードのみ掲載します。

■改造版マクロソース
※標準モジュールの関数【OpeOval】のコード部分のみ

/////↓ここから///////////////////////////////////
Option Explicit
Option Base 0

'================================================
'関数名： OpeOval
'機　能：【楕円】の描画or消去
'引　数： ByVal nOpeMode As Integer
'　　　　 ・描画or消去の指定
'　　　　　　=0：消去、=1：描画
'戻り値： なし
'================================================
Sub OpeOval(ByVal nOpeMode As Integer)

　　Dim x0 As Double　　　　'セルの座標（Left）
　　Dim y0 As Double　　　　'セルの座標（Top）
　　Dim w0 As Double　　　　'セルの幅（Width）
　　Dim h0 As Double　　　　'セルの高さ（Height）
　　Dim x1 As Double　　　　'楕円図形の座標（Left）
　　Dim y1 As Double　　　　'楕円図形の座標（Top）
　　Dim w1 As Double　　　　'楕円図形の幅（Width）
　　Dim h1 As Double　　　　'楕円図形の高さ（Height）
　　Dim vShtName As Variant 'シート名の配列
　　Dim nShtNum As Integer　'シート数
　　Dim nShtCnt As Integer　'シート数のカウンタ
　　Dim vCelAdrs As Variant 'セルアドレスの配列
　　Dim nCelNum As Integer　'セル数
　　Dim nCelCnt As Integer　'セル数のカウンタ
　　Dim sht As Worksheet　　'シート取得用（Worksheetオブジェクト）
　　Dim shp As Shape　　　　'図形取得用（Shapeオブジェクト）

　　'シート名の配列を作成＆シート数を取得
　　vShtName = Array("Sheet2", "Sheet3")
　　nShtNum = UBound(vShtName) + 1

　　'シートの数だけループ
　　For nShtCnt = 0 To nShtNum - 1
　　　　'シート取得
　　　　Set sht = Worksheets(vShtName(nShtCnt))

　　　　'操作セルのアドレス配列を作成＆セル数を取得
　　　　'※変更後（セルアドレスを結合セルのアドレスに変更）
　　　　If nShtCnt = 0 Then
　　　　　　vCelAdrs = Array("AJ3:AL3", "CH3:CJ3")
　　　　Else
　　　　　　vCelAdrs = Array("AJ3:AL3", "CH3:CJ3")
　　　　End If
　　　　nCelNum = UBound(vCelAdrs) + 1

　　　　'対象のセルの数だけループ
　　　　For nCelCnt = 0 To nCelNum - 1

''===============================================
''　　　　　'既存の楕円図形を消去
''　　　　　'※変更前（こちらはコメントのままか削除して下さい。）
''　　　　　For Each shp In sht.Shapes
''　　　　　　 If shp.TopLeftCell.Address = _
''　　　　　　　　　sht.Range(vCelAdrs(nCelCnt)).Address Then
''　　　　　　　　　shp.Delete
''　　　　　　　　　Exit For
''　　　　　　　End If
''　　　　　Next
''===============================================

　　　　　　'既存の楕円図形を消去
　　　　　　'※変更後（結合セル対応版）
　　　　　　For Each shp In sht.Shapes
　　　　　　　　If Not Application.Intersect(shp.TopLeftCell, _
　　　　　　　　　　sht.Range(vCelAdrs(nCelCnt))) Is Nothing Then
　　　　　　　　　　shp.Delete
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next

　　　　　　'描画or消去モードのチェック
　　　　　　'※描画モードの時のみ楕円描画
　　　　　　If nOpeMode = 1 Then
　　　　　　　　'セルの座標を取得
　　　　　　　　With sht.Range(vCelAdrs(nCelCnt))
　　　　　　　　　　x0 = .Left
　　　　　　　　　　y0 = .Top
　　　　　　　　　　w0 = .Width
　　　　　　　　　　h0 = .Height
　　　　　　　　End With
　　　　　　　　'楕円図形の座標を計算
　　　　　　　　w1 = w0 * 0.9
　　　　　　　　h1 = h0 * 0.7
　　　　　　　　x1 = x0 + ((w0 - w1) / 2#)
　　　　　　　　y1 = y0 + ((h0 - h1) / 2#)
　　　　　　　　'楕円図形を描画
　　　　　　　　Set shp = sht.Shapes.AddShape(msoShapeOval, x1, y1, w1, h1)
　　　　　　　　With shp
　　　　　　　　　　.Fill.Visible = msoTrue
　　　　　　　　　　.Fill.Solid
　　　　　　　　　　.Fill.ForeColor.SchemeColor = 9
　　　　　　　　　　.Fill.Transparency = 1#
　　　　　　　　　　.Line.Weight = 1.25
　　　　　　　　　　.Line.DashStyle = msoLineSolid
　　　　　　　　　　.Line.Style = msoLineSingle
　　　　　　　　　　.Line.Transparency = 0#
　　　　　　　　　　.Line.Visible = msoTrue
　　　　　　　　　　.Line.ForeColor.SchemeColor = 10
　　　　　　　　　　.Line.BackColor.RGB = RGB(255, 255, 255)
　　　　　　　　End With
　　　　　　　　'Shapeオブジェクトの解放
　　　　　　　　Set shp = Nothing
　　　　　　End If
　　　　　　'次のセルへ
　　　　Next nCelCnt

　　　　'Worksheetオブジェクトの解放
　　　　Set sht = Nothing
　　　　'次のシートへ
　　Next nShtCnt

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

添付画像は、改造後のマクロを実行した際のExcelシートのキャプチャ画像です。
※もしも、画像が貼れていなかった場合はすみません。

以上です。

お礼

FarEyes様
毎回詳しいご説明を加えた回答、有り難う御座います。自分のような初心者には大変勉強になります。誠に有り難う御座います。

回答No.6

noname#144013

こんにちは。　FarEyesです。　※連投ですみません。

#5の件で、ひとつ注意点があります。

#5の改造前のバージョンのExcelブックを使用して、既にマクロ内のセルのアドレスを
結合セルのアドレスに書き換えて動作テストを行い、何回かトグルボタンを、ON/OFF
していた場合ですが、

　　トグルボタンOFFで楕円が消されないために、一見、ひとつのセル範囲に、
　　楕円がひとつしか描画されていないように見えても、実際は、同じ位置に
　　複数の楕円（同じ位置＆同じ形）が重なって描画されている状態になって
　　いるかもしれません。

その状態のまま、#5のマクロの改造を行い、実際に動作させた場合に、

　　一回のトグルボタンのON/OFFでは、ひとつの楕円しか消去されないため、
　　ひとつ楕円を消しても、まだ、重なっている楕円が残っているため、見た目上
　　消されていないように見えてしまう場合があると思います。

　　※ただし、トグルボタンのONで１個消して１個描画、次のトグルボタンのOFF
　　　で、また１個消すことになるので、トグルボタンの一回の往復操作（ON/OFF）
　　　で、２個の楕円が消されることになります。
　　　そのため、何回か、ボタンをON/OFFしていると、そのうち残っている楕円全て
　　　が消されることにはなりますが。。。

ですので、動作テストする場合は、一旦、手動で楕円図形を全て削除するか、
または、新規にExcelブックを作成して、そのブックにシートのコピー（図形以外）
とマクロのコピーを行ってから、動作テストを行った方が良いと思います。

以上です。

お礼

FarEyes様
再度の回答有り難う御座います。
頂いたご注意を踏まえた上で、これから訂正等をさせて頂きます。本当に有り難う御座います。

回答No.4

noname#144013

こんにちは。　FarEyesです。

確認なのですが、

> 但し楕円の大きさが合っていないので、これから自動マクロ書き込みを利用して座標
> を確認し、コードを自力で変更してみようと思います。

#2のマクロでは、楕円の大きさは、セルの大きさに合わせてセル内に納まるように、
適度な大きさ（セルの大きさの80%ぐらい？）になるように処理（※下記のコード部分）
しているつもりだったのですが、
質問者さんの環境ではそれが、『上手くいっていない』ということでしょうか？
※認識違いでしたら、すみません。

　　◎#2のマクロでの楕円描画部分のコード
　　　====================================================
　　　　'セルの座標を取得
　　　　With sht.Range(vCelAdrs(nCelCnt))
　　　　　　x0 = .Left　　　　　　　　　’セルの左端のX座標
　　　　　　y0 = .Top　　　　　　　　　’セルの上端のY座標
　　　　　　w0 = .Width　　　　　　　　’セルの幅
　　　　　　h0 = .Height　　　　　　　　’セルの高さ
　　　　End With
　　　　'楕円図形の座標を計算
　　　　w1 = w0 * 0.9　　　　　　　　　　’楕円の幅（セルの幅の90%）
　　　　h1 = h0 * 0.7　　　　　　　　　　’楕円の高さ（セルの高さの70%）
　　　　x1 = x0 + ((w0 - w1) / 2#)　　’楕円の左端のX座標
　　　　y1 = y0 + ((h0 - h1) / 2#)　　’楕円の上端のY座標
　　　　'楕円図形を描画
　　　　Set shp = sht.Shapes.AddShape(msoShapeOval, x1, y1, w1, h1)
　　　====================================================

差し支えなければ、今後の参考のために、質問者さんが書かれたコード部分
（※できれば楕円描画に関連するコード全体）を、ご提示願えないでしょうか？

誠に勝手な要望で申し訳ありませんが、何卒、宜しくお願い致します。

参考までに、#2のマクロはそのままで、ワークシートのセルの大きさのみ変更
して、マクロを実行した際の、ワークシートのキャプチャ画像を添付致します。
※このように、楕円の大きさが変わります。

以上です。宜しくお願い致します。

お礼

まず始めにFarEyes様、せっかく回答頂きました方のお名前からして間違っておりまして誠に失礼しました。
　また、回答頂きました書き込みに、『但し楕円の大きさが合っていないので、これから自動マクロ書き込みを利用して座標を確認し、コードを自力で変更してみようと思います。小さい赤丸がＡＪ３は左上端、ＣＪ３では右上端に書き込みされた状態でした。』とさせて頂きましたが、自分の確認ミスでした。実はセルＡＪ３・ＣＪ３をＡＪ３：ＡＬ３、ＣＨ３：ＣＪ３と結合していたのを忘れておりました。そのため楕円の表示がＡＪ３が左、ＣＪ３が右のセルへ表示となっていた次第です。大変申し訳ありません。FarEyes様のご指摘には間違いは御座いませんでした。
　厚かましくも再度勉強させて下さい。
自分初心者なりに、標準モジュールのコードの中で、vCelAdrs = Array("AJ3", "CJ3")をvCelAdrs = Array("AJ3:AL3", "CH3:CJ3")と変更してみましたが、ボタンＯＮで書き込みはＯＫですが、ボタンＯＦＦで消し込みが出来ません。自分もセルに関わる部分を訂正しないとまでは解りますが、その部分が解りません。再度ご教授頂けませんでしょうか。宜しくお願いします。

補足

何分初心者なのでコードが読み切れておらず、セル内で自動設定になっている事自体解っておりませんでした。＃２様、理解出来ませんで申し訳ありません。また補足頂きましたFarEyes様、有り難う御座います。大変勉強になります。
お礼文を書き込みしてから、まだコードの変更を試みておりません。＃２様のコードを実行しました時点では、小さい赤丸がＡＪ３は左上端、ＣＪ３では右上端に書き込みされた状態でした。
変更を試みてから状況をご報告させて頂きたいと思います。

回答No.3

noname#144013

#2です。
#2で画像添付に失敗したみたいです。すみませんでした。
今回の投稿でリトライしてみますが、今回もダメだったら
申し訳ございません。

お礼

画像有り難う御座います。

回答No.2

noname#144013

こんにちは。

サンプルマクロを作成してみました。
楕円図形の描画部分もマクロ内で行っています。

当方は、Excel2000で作成しましたので、他のバージョンのExcelで上手く動作
するかどうか判りません。
※上手く動作しなかった場合はすみません。

デバッグ用のコードも含めていますので、必要ない場合は、その部分を削除して
下さい。
※デバッグ用コード　⇒　コメント"'@@:DBG"で挟まれている部分です。

マクロ中の下記部分、
　　・トグルボタン名（オブジェクト名）　：　"ToggleButton1"
　　・ワークシート名　：　"Sheet2"、"Sheet3"　など
　　・セルアドレス　　：　"AJ3"、"CJ3"　など
等の記述部分は、実際に御使用されるExcelブックに合わせて、適せん変更して
下さい。

■サンプルマクロ
注）インデント等のため、全角スペースを入れています。

１）ワークシート（トグルボタンを実装しているシート）のマクロ
　・このマクロは、「Worksheet」のコードモジュールに実装して下さい。

/////↓ここから///////////////////////////////////
Option Explicit
Option Base 0

'== トグルボタンのクリック時処理 ==
Private Sub ToggleButton1_Click()

　　'トグルボタンの状態変化をチェック
　　If ToggleButton1.Value = True Then
　　　　'トグルボタンがOFF→ONになった時
'@@:DBG
　　　　'デバッグ用：状態変化の表示（イミディエイトウィンドウ向け）
　　　　Debug.Print "ToggleButton1: OFF→ON"
'@@:DBG
　　　　'楕円描画の実行
　　　　Call OpeOval(1)
　　　　'トグルボタンのキャプションを"ON"にして[太字]に変更
　　　　ToggleButton1.Caption = "ON"
　　　　ToggleButton1.Font.Bold = True
　　　　'トグルボタンの背景色を[赤]、文字色を[黒]に変更
　　　　ToggleButton1.BackStyle = fmBackStyleOpaque
　　　　ToggleButton1.BackColor = RGB(255, 0, 0)
　　　　ToggleButton1.ForeColor = RGB(0, 0, 0)
　　Else
　　　　'トグルボタンがON→OFFになった時
'@@:DBG
　　　　'デバッグ用：状態変化の表示（イミディエイトウィンドウ向け）
　　　　Debug.Print "ToggleButton1: ON→OFF"
'@@:DBG
　　　　'楕円消去の実行
　　　　Call OpeOval(0)
　　　　'トグルボタンのキャプションを"OFF"にして[太字]を解除
　　　　ToggleButton1.Caption = "OFF"
　　　　ToggleButton1.Font.Bold = False
　　　　'トグルボタンの背景色、文字色を[標準]に戻す
　　　　ToggleButton1.BackStyle = fmBackStyleOpaque
　　　　ToggleButton1.BackColor = &H8000000F
　　　　ToggleButton1.ForeColor = &H80000012
　　End If

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

２）標準モジュールのマクロ
　・このマクロは、「標準モジュール」を追加して、そのコードモジュールに実装
　　して下さい。

/////↓ここから///////////////////////////////////
Option Explicit
Option Base 0

'================================================
'関数名： OpeOval
'機　能：【楕円】の描画or消去
'引　数： ByVal nOpeMode As Integer
'　　　　 ・描画or消去の指定
'　　　　　　=0：消去、=1：描画
'戻り値： なし
'================================================
Sub OpeOval(ByVal nOpeMode As Integer)

　　Dim x0 As Double　　　　'セルの座標（Left）
　　Dim y0 As Double　　　　'セルの座標（Top）
　　Dim w0 As Double　　　　'セルの幅（Width）
　　Dim h0 As Double　　　　'セルの高さ（Height）
　　Dim x1 As Double　　　　'楕円図形の座標（Left）
　　Dim y1 As Double　　　　'楕円図形の座標（Top）
　　Dim w1 As Double　　　　'楕円図形の幅（Width）
　　Dim h1 As Double　　　　'楕円図形の高さ（Height）
　　Dim vShtName As Variant 'シート名の配列
　　Dim nShtNum As Integer　'シート数
　　Dim nShtCnt As Integer　'シート数のカウンタ
　　Dim vCelAdrs As Variant 'セルアドレスの配列
　　Dim nCelNum As Integer　'セル数
　　Dim nCelCnt As Integer　'セル数のカウンタ
　　Dim sht As Worksheet　　'シート取得用（Worksheetオブジェクト）
　　Dim shp As Shape　　　　'図形取得用（Shapeオブジェクト）

　　'シート名の配列を作成＆シート数を取得
　　vShtName = Array("Sheet2", "Sheet3")
　　nShtNum = UBound(vShtName) + 1

　　'シートの数だけループ
　　For nShtCnt = 0 To nShtNum - 1
　　　　'シート取得
　　　　Set sht = Worksheets(vShtName(nShtCnt))

　　　　'操作セルのアドレス配列を作成＆セル数を取得
　　　　If nShtCnt = 0 Then
　　　　　　vCelAdrs = Array("AJ3", "CJ3")
　　　　Else
　　　　　　vCelAdrs = Array("AJ3", "CJ3")
　　　　End If
　　　　nCelNum = UBound(vCelAdrs) + 1

　　　　'対象のセルの数だけループ
　　　　For nCelCnt = 0 To nCelNum - 1
　　　　　　'既存の楕円図形を消去
　　　　　　For Each shp In sht.Shapes
　　　　　　　　If shp.TopLeftCell.Address = _
　　　　　　　　　 sht.Range(vCelAdrs(nCelCnt)).Address Then
　　　　　　　　　　shp.Delete
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next

　　　　　　'描画or消去モードのチェック
　　　　　　'※描画モードの時のみ楕円描画
　　　　　　If nOpeMode = 1 Then
　　　　　　　　'セルの座標を取得
　　　　　　　　With sht.Range(vCelAdrs(nCelCnt))
　　　　　　　　　　x0 = .Left
　　　　　　　　　　y0 = .Top
　　　　　　　　　　w0 = .Width
　　　　　　　　　　h0 = .Height
　　　　　　　　End With
　　　　　　　　'楕円図形の座標を計算
　　　　　　　　w1 = w0 * 0.9
　　　　　　　　h1 = h0 * 0.7
　　　　　　　　x1 = x0 + ((w0 - w1) / 2#)
　　　　　　　　y1 = y0 + ((h0 - h1) / 2#)
　　　　　　　　'楕円図形を描画
　　　　　　　　Set shp = sht.Shapes.AddShape(msoShapeOval, x1, y1, w1, h1)
　　　　　　　　With shp
　　　　　　　　　　.Fill.Visible = msoTrue
　　　　　　　　　　.Fill.Solid
　　　　　　　　　　.Fill.ForeColor.SchemeColor = 9
　　　　　　　　　　.Fill.Transparency = 1#
　　　　　　　　　　.Line.Weight = 1.25
　　　　　　　　　　.Line.DashStyle = msoLineSolid
　　　　　　　　　　.Line.Style = msoLineSingle
　　　　　　　　　　.Line.Transparency = 0#
　　　　　　　　　　.Line.Visible = msoTrue
　　　　　　　　　　.Line.ForeColor.SchemeColor = 10
　　　　　　　　　　.Line.BackColor.RGB = RGB(255, 255, 255)
　　　　　　　　End With
　　　　　　　　'Shapeオブジェクトの解放
　　　　　　　　Set shp = Nothing
　　　　　　End If
　　　　　　'次のセルへ
　　　　Next nCelCnt

　　　　'Worksheetオブジェクトの解放
　　　　Set sht = Nothing
　　　　'次のシートへ
　　Next nShtCnt

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

添付画像は、上記マクロを実装したExcelブックの画面キャプチャです。
※見辛かったらすみません。

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

お礼

ご回答を頂き有り難う御座います。
解答頂きましたコードを今作成中のExcelへ盛り込んでみたところ、実行されました。但し楕円の大きさが合っていないので、これから自動マクロ書き込みを利用して座標を確認し、コードを自力で変更してみようと思います。
非常に解りやすく丁寧に説明文も入れて頂き、初心者へのお心遣いいたみいります。まずここから勉強させて頂きます。重ねてお礼申し上げます。

回答No.1

mimeu

こんな感じでしょうか。
楕円を書いたり消したりするのは、
はじめから書いておいて、表示にしたり非表示にしたりすることで。

Private Sub ToggleButton1_Click()
　　If ToggleButton1.Value Then
　　　　ToggleButton1.Caption = "戻してね"
　　　　ToggleButton1.BackColor = &HFF&
　　　　ToggleButton1.ForeColor = &HFF0000
　　　　楕円.Visible = True ' ４ヶ所
　　Else
　　　　ToggleButton1.Caption = "押してね"
　　　　ToggleButton1.BackColor = &H8000000F
　　　　ToggleButton1.ForeColor = &H80000012
　　　　楕円.Visible = False ' ４ヶ所
　　End If
End Sub

楕円の扱いについては、手作業で楕円を描くとき
《新しいマクロの記録》 をしておいて、その記録されたマクロを参考に
記述されたらよいと思います。

お礼

ご解答頂きまして有り難う御座います。
まだ確認までは至っておりませんが、これからマクロの自動記録を作成してから行ってみたいと思います。
何分初心者の為、また投稿の質問をさせて頂くと思いますが、その際は宜しくお願いします。有り難う御座いました、重ねてお礼を申し上げます。