[[20171208142215]]　『「オプションボタン選択で図形貼り付け」[fuwari]』（ちぇるな）　ページの最後に飛ぶ

『「オプションボタン選択で図形貼り付け」[fuwari]　について』（ちぇるな）

投稿
[[20080129130423]] 『オプションボタン選択で図形貼り付け』（fuwari）　
について...

最近マクロをはじめました。超初心者ですみません。

以前の投稿を参考にオプションボタンで
４つの文字(A6～D6)に楕円を囲いたく下記のようにしてみました。

オプションボタン選択で楕円を移動させることは
できたのですが　一列目の図形を残置させ
違う列で同じように楕円を選ばせたいのですが
うまくいきません。
説明が下手ですいません。

1 2 ?B　4 ←　３を選んだあと

5 ?E　7 8　　←　違う列で６を選びたい。

（フレームは異なります）

宜しくお願い致します。

Private Sub OptionButton1_Click()
Dim sp As Shape, r As Range, obj As Object
Set obj = Selection
Call sp_del
Set r = Range("A6")
Set sp = ActiveSheet.Shapes.AddShape _
(msoShapeOval, pc(r, 1) , pc(r, 2), pc(r, 3) * 2.5, pc(r, 3))
sp.Select
Selection.ShapeRange.Fill.Visible = False
obj.Select
End Sub

Private Sub OptionButton2_Click()
Dim sp As Shape, r As Range, obj As Object
Set obj = Selection
Call sp_del
Set r = Range("B6")
Set sp = ActiveSheet.Shapes.AddShape _
(msoShapeOval, pc(r, 1) , pc(r, 2), pc(r, 3) * 2.5, pc(r, 3))
sp.Select
Selection.ShapeRange.Fill.Visible = False
obj.Select
End Sub

Private Sub OptionButton3_Click()
Dim sp As Shape, r As Range, obj As Object
Set obj = Selection
Call sp_del
Set r = Range("C6")
Set sp = ActiveSheet.Shapes.AddShape _
(msoShapeOval, pc(r, 1), pc(r, 2), pc(r, 3) * 2.5, pc(r, 3))
sp.Select
Selection.ShapeRange.Fill.Visible = False
obj.Select
End Sub

Private Sub OptionButton4_Click()

 Dim sp As Shape, r As Range, obj As Object
Set obj = Selection
Call sp_del
Set r = Range("D6")
Set sp = ActiveSheet.Shapes.AddShape _
(msoShapeOval, pc(r, 1) , pc(r, 2), pc(r, 3) * 2.5, pc(r, 3))
sp.Select
Selection.ShapeRange.Fill.Visible = False
obj.Select
End Sub

Private Sub sp_del()
Dim sp As Shape
For Each sp In ActiveSheet.Shapes

    If Not Intersect(Range("A6:B6:C6:D6"), _
        Range(sp.TopLeftCell, sp.BottomRightCell)) Is Nothing Then
        sp.Delete
    End If
Next
End Sub

Private Function pc(r As Range, i As Integer) As Single
With WorksheetFunction

    Select Case i
        Case 1
            pc = r.Left + r.Width / 2 - .Min(r.Height, r.Width) / 2
        Case 2
            pc = r.Top + r.Height / 2 - .Min(r.Height, r.Width) / 2
        Case 3
            pc = .Min(r.Height, r.Width)
    End Select
End With
End Function

＜使用 Excel：Excel2013、使用 OS：Windows10 ＞

ちゃんとコーディング通り動いているようですが、「うまくいかない」という内容を、具体的に説明してください。

コード内容は、ボタンクリックすると、指定範囲内にある図形を消してから、新たな楕円を置いていますね。オプションボタンは常に1つしかONにならないので、これと連動した正しいロジックだと思います。

残置、と言っているのが、前の図形を消さないという意味ならば、sp_del というプロシジャで消しているので、これをコメントアウトして動かなくするだけです。しかし、そんな事をすると、クリックする度に楕円が増殖していって、4箇所全てに○が付いてしまうだけですよ？（4箇所どころか、押す度に上に重なって何個でも図形が貼られてしまいます）それは変ですよね。
（???） 2017/12/08(金) 15:35

 最初はA列で選択したボタンに対応する行に丸を付ける。
 A列での選択が終了すると次はB列で選択したボタンに対応する行に丸を付ける。
 B列での選択が終了したら次はC列で選択したボタンに対応する行に丸を付ける。
 ということだと思うが列での選択終了は何を持って判断させるのだろうか？
（ねむねむ） 2017/12/08(金) 15:44

 おっと行と列が逆か。
 1行目で選択。
 次は2行目で選択。
 行の選択終了の判断は？
（ねむねむ） 2017/12/08(金) 15:47

質問が下手ですみません。

ユーザーフォームに複数のフレームを作りました。

Frame1---------------------------------------

りんご　　〇みかん　　バナナ　　スイカ

Frame2---------------------------------------

ぶどう　　パイン　　〇レモン　　なし

Frame1の図形は選択したら　１つ残置させ（みかん）
フレーム２の選択時に　フレーム１が消えないように
つぎの図形を選択させたいのです。（レモン）

上記の数式をダブルで書いてしまうと
レモンを選択すると　みかんの図形が消えてしまします。

ようは　複数の選択を１か所づつ　図形を残していきたいのですが

宜しくお願い致します。

（ちぇるな） 2017/12/08(金) 16:15

ボタンは4つではなく、8つに増やしたのですね…。意味不明だった訳です。そして、1つの選択が横に4セルなのだし、他の選択は桁ではなく、行が違うのではないかと思うのですが、いかがでしょうか？

とりあえず、1つ目の選択はA6:D6セル、2つ目の選択はA8:D8セルだと仮定した修正例なぞ。（行が違っても、計算式を少し直すだけでしょう）

 Private Sub OptionButton1_Click()
    Call sClick(OptionButton1)
 End Sub

 Private Sub OptionButton2_Click()
    Call sClick(OptionButton2)
 End Sub

 Private Sub OptionButton3_Click()
    Call sClick(OptionButton3)
 End Sub

 Private Sub OptionButton4_Click()
    Call sClick(OptionButton4)
 End Sub

 Private Sub OptionButton5_Click()
    Call sClick(OptionButton5)
 End Sub

 Private Sub OptionButton6_Click()
    Call sClick(OptionButton6)
 End Sub

 Private Sub OptionButton7_Click()
    Call sClick(OptionButton7)
 End Sub

 Private Sub OptionButton8_Click()
    Call sClick(OptionButton8)
 End Sub

 Sub sClick(OPT As Object)
    Dim R As Range
    Dim sp As Shape
    Dim iPtn As Long
    Dim G1 As Long
    Dim G2 As Long

    Select Case OPT.Name
    Case "OptionButton1"
        G1 = 1
        iPtn = 1
    Case "OptionButton2"
        G1 = 2
        iPtn = 1
    Case "OptionButton3"
        G1 = 3
        iPtn = 1
    Case "OptionButton4"
        G1 = 4
        iPtn = 1
    Case "OptionButton5"
        G2 = 1
        iPtn = 2
    Case "OptionButton6"
        G2 = 2
        iPtn = 2
    Case "OptionButton7"
        G2 = 3
        iPtn = 2
    Case "OptionButton8"
        G2 = 4
        iPtn = 2
    Case Else
        Stop
    End Select

    For Each sp In ActiveSheet.Shapes
        If Not Intersect(Range(Cells(iPtn * 2 + 4, "A"), Cells(iPtn * 2 + 4, "D")), _
            sp.TopLeftCell) Is Nothing Then
            sp.Delete
        End If
    Next sp

    Set R = Cells(iPtn * 2 + 4, IIf(iPtn = 1, G1, G2))
    With ActiveSheet.Shapes.AddShape(msoShapeOval, R.Left, R.Top, R.Width, R.Height)
        .Fill.Visible = False
    End With
 End Sub
（???） 2017/12/08(金) 17:07

列位置を保持する変数G1、G2は、1つあれば十分でしたね。不用意に難しくしてしまいました…。

あと、セルいっぱいに楕円を描くようにしましたが、セルの左端に真円を描くように直すならば、R.Widthを指定している箇所を R.Height に変えれば良いです。
（???） 2017/12/08(金) 17:29

（???）さん　返信ありがとうございました。

早速試してみました。動き方はこれでOKなのですが
欲をいうと
セルごと移動というより文字を微調整しながら楕円をつけたかったのです。

例えば　
　　　A　　B 　 C 　 D 　 E 　 F 　 G 　　H
6　[　りんご・みかん・バナナ・スイカ　　　]←セルが結合しています。
8　 [　ぶどう・パイン・レモン・なし　　　　]←セルが結合しています。

6行で選択後　8行でまた選択

(msoShapeOval, pc(r, 1)+4, pc(r, 2), pc(r, 3) * 2.5, pc(r, 3))
+4とか足しながら微調整してました。

6行目で１回選択し楕円を残置させ、
次の命令で8行目を選択させることは可能でしょうか。

なんどもすみません。

宜しくお願い致します。

（ちぇるな） 2017/12/11(月) 09:05

8セル全部結合せず、2セルずつ結合すれば簡単だし、ずれなくて良いと思うのですが…。
変更したいのは楕円の幅くらいだと思うのですが、とりあえず、変更案なぞ。左右の間隔は、iSPCの値で調節してみてください。

 Sub sClick(OPT As Object)
    Const iSPC = 8
    Dim R As Range
    Dim sp As Shape
    Dim iPtn As Long
    Dim iGrp As Long

    Select Case OPT.Name
    Case "OptionButton1": iGrp = 1: iPtn = 1
    Case "OptionButton2": iGrp = 2: iPtn = 1
    Case "OptionButton3": iGrp = 3: iPtn = 1
    Case "OptionButton4": iGrp = 4: iPtn = 1
    Case "OptionButton5": iGrp = 1: iPtn = 2
    Case "OptionButton6": iGrp = 2: iPtn = 2
    Case "OptionButton7": iGrp = 3: iPtn = 2
    Case "OptionButton8": iGrp = 4: iPtn = 2
    Case Else
        Stop
    End Select

    For Each sp In ActiveSheet.Shapes
        If Not Intersect(Range(Cells(iPtn * 2 + 4, "A"), Cells(iPtn * 2 + 4, "H")), sp.TopLeftCell) Is Nothing Then
            sp.Delete
        End If
    Next sp

    Set R = Cells(iPtn * 2 + 4, "A")
    With ActiveSheet.Shapes.AddShape(msoShapeOval, R.Width * 2 * (iGrp - 1) + iSPC, R.Top, (R.Width - iSPC) * 2, R.Height)
        .Fill.Visible = False
    End With
 End Sub
（???） 2017/12/11(月) 11:11

（???）さま

いろいろとご教授くださりありがとうございました。m(__)m
大変助かりました。
また解らないことありましたら
ご質問させて頂きます。
そのときは宜しくお願い致します。

（ちぇるな） 2017/12/11(月) 12:05

コメント返信：

[ 一覧(最新更新順) ]

[[20171208142215]] 『「オプションボタン選択で図形貼り付け」[fuwari]』（ちぇるな） ページの最後に飛ぶ

[[20171208142215]]　『「オプションボタン選択で図形貼り付け」[fuwari]』（ちぇるな）　ページの最後に飛ぶ