Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Excel 2016)
シートモジュールで指定セルに対する処理
投稿日時: 21/07/08 14:04:36
投稿者: torao

お世話になっております。
 
セルのに値があり、そのセルを右クリックするとその文字をシェイプで囲むという処理を行っております。
下記にアップしているコードは現在使用しているものです。
処理は、単一セルのみしか動作しません。
これを複数のセルを選択した状態で右クリックするとシェイプが適用されるという処理を考えております。
 
 
下記コードは
 
 ・シート内の指定範囲(G15:M20)にある
 ・「任意」の「単一」のセルに対して
 ・シェイプををセルに表示させる
 
処理となります。
 
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Dim Lp As Single, Tp As Single, Wp As Single, Hp As Single
    If Intersect(Target, Range("G15:M20")) Is Nothing Then Exit Sub
    Cancel = True
    With Target
        Lp = .Left: Tp = .Top: Wp = .Width: Hp = .Height
    End With
    With ActiveSheet.Shapes.AddShape(msoShapeOval, Lp, Tp, Wp, Hp)
        .OnAction = "shape消去" '標準モジュールに設定
        .Fill.Visible = msoFalse
        With .Line
            .Weight = 0.25
            .DashStyle = msoLineSolid
            .Style = msoLineSingle
            .Visible = msoTrue
            .ForeColor.SchemeColor = 64
        End With
    End With
End Sub
 
質問は
 
 ・シート内の指定範囲にある
 ・「任意」の「複数」のセルに対して
  ※任意の複数セルとは「連続したセル範囲」や「飛び飛びに選択したセル」に対してを想定しています。
 ・dシェイプをセルに表示させる
 
皆様、何卒アドバイスのほどよろしくおねがいします。

回答
投稿日時: 21/07/08 15:28:48
投稿者: WinArrow
投稿者のウェブサイトに移動

質問の確認です。
 
複数のセルを対象にした場合
 
各々のセルに図形を作成したいのか?
選択したセルを矩形として図形を作成したのか?
どちらなんでしょう。
 
掲示のコードは、連続したセルならば、その範囲で図形が作成されます。
 
各々のセルに
というならば、Targetを分解すればよいでしょう。

回答
投稿日時: 21/07/08 15:43:52
投稿者: WinArrow
投稿者のウェブサイトに移動

選択したセルの各々に図形を作成する例コード
 

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Dim Lp As Single, Tp As Single, Wp As Single, Hp As Single
    If Intersect(Target, Range("G15:M20")) Is Nothing Then
        Cancel = True
        Exit Sub
    End If
    Cancel = True
    Dim myCell As Range, shape As shape
    For Each myCell In Target
        With myCell
             Lp = .Left: Tp = .Top: Wp = .Width: Hp = .Height
            Set shape = ActiveSheet.Shapes.AddShape(msoShapeOval, Lp, Tp, Wp, Hp)
            GoSub CreateShape
            Set shape = Nothing
        End With
    Next
    Exit Sub


CreateShape:
    With shape
        .OnAction = "shape消去" '標準モジュールに設定
        .Fill.Visible = msoFalse
        With .Line
            .Weight = 0.25
            .DashStyle = msoLineSolid
            .Style = msoLineSingle
            .Visible = msoTrue
            .ForeColor.SchemeColor = 64
        End With
    End With
    Return
End Sub

回答
投稿日時: 21/07/08 17:57:08
投稿者: mattuwan44

単一ができてるなら、巡回してそれを繰り返し呼び出せばよいかと思います。
 

Option Explicit

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Dim c As Range
    
    Set Target = Intersect(Me.Range("G15:M20"), Target)
    If Target Is Nothing Then Exit Sub
    Cancel = True
        
    For Each c In Target
        囲む c
    Next
End Sub

Private Sub 囲む(ByVal pTarget As Range)
    Dim Lp As Single, Tp As Single, Wp As Single, Hp As Single
    With pTarget
        Lp = .Left: Tp = .Top: Wp = .Width: Hp = .Height
    End With
    
    With ActiveSheet.Shapes.AddShape(msoShapeOval, Lp, Tp, Wp, Hp)
        .OnAction = "shape消去" '標準モジュールに設定
        .Fill.Visible = msoFalse
        With .Line
            .Weight = 0.25
            .DashStyle = msoLineSolid
            .Style = msoLineSingle
            .Visible = msoTrue
            .ForeColor.SchemeColor = 64
        End With
    End With
End Sub

 
たぶん、選択肢の中から選択するのでしょうから、
僕なら単一セルダブルクリックで、対象セルに図形を移動するかな。

投稿日時: 21/07/08 21:15:25
投稿者: torao

WinArrow さん
mattuwan44 さん
 
早速のアドバイス有難うございます。
コード確認したところバッチリ動作しております。感謝申し上げます。
 
 アドバイス頂いたコードに以下2点を追加してみました。
 ・適用範囲をUnionを使用・・・セル指定範囲が長くなるため単に改行したかったため
 ・結合セルがある場合・・・結合セル単位でシェイプ丸囲みできるよう判定
 
 
 一応、動作確認してうまく動いておりますが、ご指摘事項がありましたらお願いします。
 特にない場合は、明日の夜にでも解決としたいと思います。
 
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Dim flag As Boolean
    Dim Lp As Single, Tp As Single, Wp As Single, Hp As Single
    '▼セル番地格納
    If Intersect(Target, Union( _
        Range("J5,L5,R5,T5,V5,X5,Z5,G6,J6,M6,Q6,T6,W6"), _
        Range("G15:M20,P15:V20,Y15:AE20"), _
        Range("J62,L62,R62,T62,V62,X62,Z62,G63,J63,M63,Q63,T63,W63"), _
        Range("G72:M77,P72:V77,Y72:AE77"))) Is Nothing Then
        Cancel = True
        Exit Sub
    End If
    Cancel = True
    '▼選択セルが単一セルか結合セルか判定
    '※結合セルは特定項目行のみで「単一セルと混在しない・複数選択しない」ため下記で判定する
    If Target.MergeCells Then
        flag = True
    End If
    Dim myCell As Range, shape As shape
    If flag = True Then '@単一セルの場合
        With Target
            Lp = .Left: Tp = .Top: Wp = .Width: Hp = .Height
            Set shape = ActiveSheet.Shapes.AddShape(msoShapeOval, Lp, Tp, Wp, Hp)
            GoSub CreateShape
            Set shape = Nothing
        End With
        Exit Sub
    Else 'A複数セルの場合
        For Each myCell In Target
            With myCell
                Lp = .Left: Tp = .Top: Wp = .Width: Hp = .Height
                Set shape = ActiveSheet.Shapes.AddShape(msoShapeOval, Lp, Tp, Wp, Hp)
                GoSub CreateShape
                Set shape = Nothing
            End With
        Next
        Exit Sub
    End If
'▼シェイプ消去
CreateShape:
    With shape
        .OnAction = "shape消去" '標準モジュールに設定
        .Fill.Visible = msoFalse
        With .Line
            .Weight = 0.25
            .DashStyle = msoLineSolid
            .Style = msoLineSingle
            .Visible = msoTrue
            .ForeColor.SchemeColor = 64
        End With
    End With
    Return
End Sub

投稿日時: 21/07/08 21:28:33
投稿者: torao

mattuwan44 さん
 
見落としておりました。

引用:
たぶん、選択肢の中から選択するのでしょうから、
僕なら単一セルダブルクリックで、対象セルに図形を移動するかな。

 
上記の件ですが・・そうなんです!!妥協してしまいました。
ただ、条件が下記の通り複雑で諦めていました。
 
(1)選択項目から一つのみ選択(各項目は単一セルのみ)
 J5,L5,R5,T5,V5,X5,Z5
 J62,L62,R62,T62,V62,X62,Z62
(2)選択項目から一つのみ選択(各項目は結合セルの集合体 ※結合セルは2セル、3セル混在)
 G6,J6,M6,Q6,T6,W6
 G63,J63,M63,Q63,T63,W63
(3)複数選択セル全てにシェイプ表示(各項目は単一セルしかありません)
 G15:M20,P15:V20,Y15:AE20
 G72:M77,P72:V77,Y72:AE77
 

回答
投稿日時: 21/07/08 23:34:39
投稿者: WinArrow
投稿者のウェブサイトに移動

結合セルだけの処理を掲示していますが、
 
結合セルを含む、複数セル対象の場合、
 
For Each myCell In Target
でも、結合セルを判別して対応きます。
結合セルの左上セルを判断すればよいです。
 
 
サンプルコード

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Dim Lp As Single, Tp As Single, Wp As Single, Hp As Single
    If Intersect(Target, Range("G15:M20")) Is Nothing Then
        Cancel = True
        Exit Sub
    End If
    Cancel = True
    Dim myCell As Range, shape As shape
        
    For Each myCell In Target
        If myCell.MergeCells Then
            If myCell.MergeArea.Cells(1).Address = myCell.Address Then
               With myCell.MergeArea
                     Lp = .Left: Tp = .Top: Wp = .Width: Hp = .Height
                    Set shape = ActiveSheet.Shapes.AddShape(msoShapeOval, Lp, Tp, Wp, Hp)
                    GoSub CreateShape
                    Set shape = Nothing
                End With
            End If
        Else
            With myCell
                 Lp = .Left: Tp = .Top: Wp = .Width: Hp = .Height
                Set shape = ActiveSheet.Shapes.AddShape(msoShapeOval, Lp, Tp, Wp, Hp)
                GoSub CreateShape
                Set shape = Nothing
            End With
        End If
    Next
    Exit Sub


CreateShape:
    With shape
        .OnAction = "shape消去" '標準モジュールに設定
        .Fill.Visible = msoFalse
        With .Line
            .Weight = 0.25
            .DashStyle = msoLineSolid
            .Style = msoLineSingle
            .Visible = msoTrue
            .ForeColor.SchemeColor = 64
        End With
    End With
    Return
End Sub

回答
投稿日時: 21/07/08 23:39:37
投稿者: WinArrow
投稿者のウェブサイトに移動

あと、対象セル範囲を、UNIONで集合化しているが、
変更があった場合など、コードの中に記述すると、間違えやすいし、面倒です。
もっとスマートになると思います。工夫できませんか?

回答
投稿日時: 21/07/09 10:24:51
投稿者: WinArrow
投稿者のウェブサイトに移動

WinArrow さんの引用:
あと、対象セル範囲を、UNIONで集合化しているが、
変更があった場合など、コードの中に記述すると、間違えやすいし、面倒です。
もっとスマートになると思います。工夫できませんか?

 
続きレス
 
コードの中に、セルアドレスを記述すると
例えば、行や列の追加/削除する必要が出てきた場合、
コードの修正が発生します。
対象セル範囲に「名前」を定義すると、
コードは、「名前」で記述できます。
こうすることによって、コードのメンテナンスを少なくすることができます。

投稿日時: 21/07/09 10:43:08
投稿者: torao

WinArrow さん
 
ありがとうございます。
名前の定義の件ですが、ファイルの運用方法は原本シートをコピーしながら使用しますので名前定義に影響などはございませんでしょうか?
 
アドバイスいただいたコードですが、これから試してみます。
何から何までありがとうございます。

回答
投稿日時: 21/07/09 11:14:35
投稿者: WinArrow
投稿者のウェブサイトに移動

原本シートに、名前定義しておけば、名前も一緒に複写されます。
 
注意事項
原本ブックに中に、複数のシートがあって、シート間で名前で参照している場合、
1つのシートだけ複写すると、原本ブックを参照することがあります。
名前定義は、ブック単位とシート単位があります。
シート単位で名前定義するとよいかも・・・・
 
シート単位で名前定義した場合、
Workbooks("ブック").Sheets(1).Range("なまえA")
のような記述ができます。
 
ブック単位で定義した場合
Workbooks("ブック").Names("なまえ").RefersToRange
のような記述ができます。

投稿日時: 21/07/10 22:13:27
投稿者: torao

皆さんのアドバイスを元に全体を見直しました。
 
・4つのセルエリアについては、丸シェイプを1つのみ表示させるように改善
 
 課題→標準モジュールに作成した4パターンのコードがまとめることができるか?
    シェイプに名前をつけることで、Target毎に選択項目を行ったり来たりできるようにしている。
    しかし、名前をつけるコード以外は全て同じ内容。
 
・カレンダーエリアについては、丸シェイプを「単一・複数・飛び飛び」選択セルに表示
 
 課題→選択セル内に空白セルがあっても丸シェイプが表示される。
 
 
シートモジュール内
'
'▼丸シェイプ/選択肢用:選択セルのみに丸シェイプを表示(選択項目を行ったり来たり)
' 処理該当セルの場合標準モジュール内の丸シェイプ表示コードを実行
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    '処理対象のセル範囲を設定
    Dim myTarget1 As Range: Set myTarget1 = Intersect(Target, Range("J5,L5,R5,T5,V5,X5,Z5"))
    Dim myTarget2 As Range: Set myTarget2 = Intersect(Target, Range("G6,J6,M6,Q6,T6,W6"))
    Dim myTarget3 As Range: Set myTarget3 = Intersect(Target, Range("J64,L64,R64,T64,V64,X64,Z64"))
    Dim myTarget4 As Range: Set myTarget4 = Intersect(Target, Range("G65,J65,M65,Q65,T65,W65"))
    '選択セルが4エリアの範囲である場合=定めた処理を実施
    If Not myTarget1 Is Nothing Then
        Cancel = True
        Call 丸囲み_区分表1
    ElseIf Not myTarget2 Is Nothing Then
        Cancel = True
        Call 丸囲み_区分表2
    ElseIf Not myTarget3 Is Nothing Then
        Cancel = True
        Call 丸囲み_区分表3
    ElseIf Not myTarget4 Is Nothing Then
        Cancel = True
        Call 丸囲み_区分表4
    Else
        Cancel = False '指定範囲外は編集モードに戻す
        Exit Sub
    End If
End Sub
'
'▼丸シェイプ/カレンダ用:指定範囲内で選択セル全てに丸シェイプを表示
' 丸を表示させたいセルの上で右クリック(単一・連続・飛び飛び対応)
' ※カレンダー全体を選択して実行した場合、空白セルも丸が表示されるのであとから消すこと
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Intersect(Target, Range("G15:M20,P15:V20,Y15:AE20,G74:M79,P74:V79,Y74:AE79")) Is Nothing Then
        Cancel = False '指定範囲外は右メニュ表示させる
        Exit Sub
    End If
    Cancel = True
    Dim myCell As Range
    Dim shape As shape, Lp As Single, Tp As Single, Wp As Single, Hp As Single
    For Each myCell In Target
        With myCell
            Lp = .Left: Tp = .Top: Wp = .Width: Hp = .Height
            Set shape = ActiveSheet.Shapes.AddShape(msoShapeOval, Lp, Tp, Wp, Hp)
            GoSub CreateShape
            Set shape = Nothing
        End With
    Next
    Exit Sub
CreateShape:
    With shape
        .OnAction = "shape消去" '標準モジュールに設定
        .Line.ForeColor.SchemeColor = 0 '黒
        .Line.Weight = 1 '線太さ
        .Fill.ForeColor.RGB = RGB(255, 0, 0) '色
        .Fill.Transparency = 1 '透過
    End With
    Return
End Sub
 
 
標準モジュール内
'▼丸シェイプ/選択肢用:選択セルのみに丸シェイプを表示(選択項目を行ったり来たり)
Sub 丸囲み_区分表1()
    With ActiveSheet
        '指定名シェイプ削除
        Dim objShp As shape
        For Each objShp In ActiveSheet.Shapes
            If objShp.Name = "区分1" Then ActiveSheet.Shapes("区分1").Delete
        Next
        '選択セル取得
        Dim myCell As Range: Set myCell = .Cells(ActiveCell.Row, ActiveCell.Column)
        With myCell.MergeArea '結合セル含
            '丸シェイプを名前をつけて表示
            Dim shape As shape, Lp As Single, Tp As Single, Wp As Single, Hp As Single
            Lp = .Left: Tp = .Top: Wp = .Width: Hp = .Height
            Dim myShp As shape: Set myShp = ActiveSheet.Shapes.AddShape(msoShapeOval, Lp, Tp, Wp, Hp)
            With myShp
                .Name = "区分1"
                .Line.ForeColor.SchemeColor = 0 '黒
                .Line.Weight = 1 '線太さ
                .Fill.ForeColor.RGB = RGB(255, 0, 0) '色
                .Fill.Transparency = 1 '透過
            End With
        End With
        Set myShp = Nothing
    End With
End Sub
Sub 丸囲み_区分表2()
    With ActiveSheet
        '指定名シェイプ削除
        Dim objShp As shape
        For Each objShp In ActiveSheet.Shapes
            If objShp.Name = "区分2" Then ActiveSheet.Shapes("区分2").Delete
        Next
        '選択セル取得
        Dim myCell As Range: Set myCell = .Cells(ActiveCell.Row, ActiveCell.Column)
        With myCell.MergeArea '結合セル含
            '丸シェイプを名前をつけて表示
            Dim shape As shape, Lp As Single, Tp As Single, Wp As Single, Hp As Single
            Lp = .Left: Tp = .Top: Wp = .Width: Hp = .Height
            Dim myShp As shape: Set myShp = ActiveSheet.Shapes.AddShape(msoShapeOval, Lp, Tp, Wp, Hp)
            With myShp
                .Name = "区分2"
                .Line.ForeColor.SchemeColor = 0 '黒
                .Line.Weight = 1 '線太さ
                .Fill.ForeColor.RGB = RGB(255, 0, 0) '色
                .Fill.Transparency = 1 '透過
            End With
        End With
        Set myShp = Nothing
    End With
End Sub
Sub 丸囲み_区分表3()
    With ActiveSheet
        '指定名シェイプ削除
        Dim objShp As shape
        For Each objShp In ActiveSheet.Shapes
            If objShp.Name = "区分3" Then ActiveSheet.Shapes("区分3").Delete
        Next
        '選択セル取得
        Dim myCell As Range: Set myCell = .Cells(ActiveCell.Row, ActiveCell.Column)
        With myCell.MergeArea '結合セル含
            '丸シェイプを名前をつけて表示
            Dim shape As shape, Lp As Single, Tp As Single, Wp As Single, Hp As Single
            Lp = .Left: Tp = .Top: Wp = .Width: Hp = .Height
            Dim myShp As shape: Set myShp = ActiveSheet.Shapes.AddShape(msoShapeOval, Lp, Tp, Wp, Hp)
            With myShp
                .Name = "区分3"
                .Line.ForeColor.SchemeColor = 0 '黒
                .Line.Weight = 1 '線太さ
                .Fill.ForeColor.RGB = RGB(255, 0, 0) '色
                .Fill.Transparency = 1 '透過
            End With
        End With
        Set myShp = Nothing
    End With
End Sub
Sub 丸囲み_区分表4()
    With ActiveSheet
        '指定名シェイプ削除
        Dim objShp As shape
        For Each objShp In ActiveSheet.Shapes
            If objShp.Name = "区分4" Then ActiveSheet.Shapes("区分4").Delete
        Next
        '選択セル取得
        Dim myCell As Range: Set myCell = .Cells(ActiveCell.Row, ActiveCell.Column)
        With myCell.MergeArea '結合セル含
            '丸シェイプを名前をつけて表示
            Dim shape As shape, Lp As Single, Tp As Single, Wp As Single, Hp As Single
            Lp = .Left: Tp = .Top: Wp = .Width: Hp = .Height
            Dim myShp As shape: Set myShp = ActiveSheet.Shapes.AddShape(msoShapeOval, Lp, Tp, Wp, Hp)
            With myShp
                .Name = "区分4"
                .Line.ForeColor.SchemeColor = 0 '黒
                .Line.Weight = 1 '線太さ
                .Fill.ForeColor.RGB = RGB(255, 0, 0) '色
                .Fill.Transparency = 1 '透過
            End With
        End With
        Set myShp = Nothing
    End With
End Sub

回答
投稿日時: 21/07/10 22:43:46
投稿者: WinArrow
投稿者のウェブサイトに移動

課題1:丸囲み_区分表1〜丸囲み_区分表4を纏めて共通化したい
 可能です。
Sub 丸囲み_区分表(引数1,引数2)
 
異なる部分を引数にします。
 
課題2;空白セルに図形は作らない。
セルの値をチェックするだけです。
 
 
 Dim myTarget1 As Range
 Dim myTarget2 As Range
 Dim myTarget3 As Range
 Dim myTarget4 As Range
折角の変数が、丸囲み_区分表1〜4のサブルーチンの中で使われていない。
敢えて言うならば、Targetだけで処理できるのではないでしょうか?

回答
投稿日時: 21/07/10 23:02:08
投稿者: WinArrow
投稿者のウェブサイトに移動

WinArrow さんの引用:

 Dim myTarget1 As Range
 Dim myTarget2 As Range
 Dim myTarget3 As Range
 Dim myTarget4 As Range
折角の変数が、丸囲み_区分表1〜4のサブルーチンの中で使われていない。
敢えて言うならば、Targetだけで処理できるのではないでしょうか?

に関して、追加れす
 
myTarget1〜4を使わなくても
 
Target.Rowを判別すれば、切り分けできます。

回答
投稿日時: 21/07/10 23:08:24
投稿者: WinArrow
投稿者のウェブサイトに移動

もう一つの追加レス。
 
> Dim myCell As Range: Set myCell = .Cells(ActiveCell.Row, ActiveCell.Column)
 
myCellとActiveCellはおなじになります。
Set MyCell = Activecell
と記述したことと同じです。
 
どのような意図があるのでしょうか?

投稿日時: 21/07/11 02:56:01
投稿者: torao

 WinArrow さん
 
思いがけず、アドバイスありがとうございます。
 
課題1:丸囲み_区分表1〜丸囲み_区分表4を纏めて共通化したい
 
の部分ですが、丸囲み_区分表1〜4にしている
各項目毎に設置した丸シェイプ名(区分1〜4)も
それぞれの箇所で制御できると考えてよろしいでしょうか?
 
早速取りかかって、ご報告致します。

投稿日時: 21/07/11 18:15:25
投稿者: torao

ご報告致します。
下記のように作成しました。
・Sub 丸囲み_区分表(引数1,引数2)化
・セル値が空欄の場合、丸シェイプを表示させない
 
ご確認のほどお願いいたします。
 
(シートモジュール)
'
'▼丸シェイプ/選択肢用:選択セルのみに丸シェイプを表示(選択項目を行ったり来たり)
' 処理該当セルの場合標準モジュール内の丸シェイプ表示コードを実行
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Intersect(Target, Range _
        ("J5,L5,R5,T5,V5,X5,Z5,G6,J6,M6,Q6,T6,W6,J64,L64,R64,T64,V64,X64,Z64,G65,J65,M65,Q65,T65,W65")) _
        Is Nothing Then
        Cancel = False '指定範囲外は右メニュ表示させる
        Exit Sub
    End If
     
    '選択セル行(Target.row)に応じたシェイプに名前(myShp_Name)をつける
    Dim myShp_Name As String, flag As Boolean
    If Target.Row = 5 Then
        myShp_Name = "区分1": flag = True
    ElseIf Target.Row = 6 Then
        myShp_Name = "区分2": flag = True
    ElseIf Target.Row = 64 Then
        myShp_Name = "区分3": flag = True
    ElseIf Target.Row = 65 Then
        myShp_Name = "区分4": flag = True
    End If
    '【標準モジュール】選択セル行に対応するシェイプ名を削除して新しいシェイプ名で選択先に表示
    If flag = True Then
        Cancel = True
        Call 丸囲み_区分表(myShp_Name)
    End If
     
End Sub
'
'▼丸シェイプ/カレンダ用:指定範囲内で選択セル全てに丸シェイプを表示
' 丸を表示させたいセルの上で右クリック(単一・連続・飛び飛び対応)※空白セル除外処理済み
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Intersect(Target, Range("G15:M20,P15:V20,Y15:AE20,G74:M79,P74:V79,Y74:AE79")) Is Nothing Then
        Cancel = False '指定範囲外は右メニュ表示させる
        Exit Sub
    End If
    Cancel = True
    Dim myCell As Range
    Dim shape As shape, Lp As Single, Tp As Single, Wp As Single, Hp As Single
    For Each myCell In Target
        With myCell
            If myCell <> "" Then '選択セル(範囲)の中に空白があれば丸シェイプは表示しない
                Lp = .Left: Tp = .Top: Wp = .Width: Hp = .Height
                Set shape = ActiveSheet.Shapes.AddShape(msoShapeOval, Lp, Tp, Wp, Hp)
                GoSub CreateShape
                Set shape = Nothing
            End If
        End With
    Next
    Exit Sub
CreateShape:
    With shape
        .OnAction = "shape消去" '標準モジュールに設定
        .Line.ForeColor.SchemeColor = 0 '黒
        .Line.Weight = 1 '線太さ
        .Fill.ForeColor.RGB = RGB(255, 0, 0) '色
        .Fill.Transparency = 1 '透過
    End With
    Return
End Sub
 
(標準モジュール)
'▼丸シェイプ/選択肢用:選択セルのみに丸シェイプを表示(選択項目を行ったり来たり)
Sub 丸囲み_区分表(myShp_Name As String)
    With ActiveSheet
        '指定名シェイプ削除
        Dim objShp As shape
        For Each objShp In ActiveSheet.Shapes
            If objShp.Name = myShp_Name Then ActiveSheet.Shapes(myShp_Name).Delete
        Next
        '選択セル取得
        Dim myCell As Range: Set myCell = ActiveCell
        With myCell.MergeArea '結合セル含
            '丸シェイプを名前をつけて表示
            Dim shape As shape, Lp As Single, Tp As Single, Wp As Single, Hp As Single
            Lp = .Left: Tp = .Top: Wp = .Width: Hp = .Height
            Dim myShp As shape: Set myShp = ActiveSheet.Shapes.AddShape(msoShapeOval, Lp, Tp, Wp, Hp)
            With myShp
                .Name = myShp_Name
                .Line.ForeColor.SchemeColor = 0 '黒
                .Line.Weight = 1 '線太さ
                .Fill.ForeColor.RGB = RGB(255, 0, 0) '色
                .Fill.Transparency = 1 '透過
            End With
        End With
        Set myShp = Nothing
    End With
End Sub

回答
投稿日時: 21/07/11 22:06:00
投稿者: WinArrow
投稿者のウェブサイトに移動

>ご確認のほどお願いいたします。
  
回答者に確認依頼されても困ります。
なぜならば、全ての状況が説明されていないし、
回答者はあなたのPCの画面をmると子できません。
自分が意図した通りの結果が得られれいればOKでよいではないですか?

投稿日時: 21/07/11 23:38:34
投稿者: torao

皆様アドバイスありがとうございます。
 
なんとか、手がかりを頂きながら作成することが出来ました。
これで、解決とさせていただきます。(^^)