[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『「オプションボタン選択で図形貼り付け」[fuwari] について』(ちぇるな)
投稿
[[20080129130423]] 『オプションボタン選択で図形貼り付け』(fuwari)
について...
最近マクロをはじめました。超初心者ですみません。
以前の投稿を参考にオプションボタンで
4つの文字(A6〜D6)に楕円を囲いたく下記のようにしてみました。
オプションボタン選択で楕円を移動させることは
できたのですが 一列目の図形を残置させ
違う列で同じように楕円を選ばせたいのですが
うまくいきません。
説明が下手ですいません。
1 2 ?B 4 ← 3を選んだあと
5 ?E 7 8 ← 違う列で6を選びたい。
(フレームは異なります)
宜しくお願い致します。
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の図形は選択したら 1つ残置させ(みかん)
フレーム2の選択時に フレーム1が消えないように
つぎの図形を選択させたいのです。(レモン)
上記の数式をダブルで書いてしまうと
レモンを選択すると みかんの図形が消えてしまします。
ようは 複数の選択を1か所づつ 図形を残していきたいのですが
宜しくお願い致します。
(ちぇるな) 2017/12/08(金) 16:15
とりあえず、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
あと、セルいっぱいに楕円を描くようにしましたが、セルの左端に真円を描くように直すならば、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行目で1回選択し楕円を残置させ、
次の命令で8行目を選択させることは可能でしょうか。
なんどもすみません。
宜しくお願い致します。
(ちぇるな) 2017/12/11(月) 09:05
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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.