[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『オプションボタン選択で図形貼り付け』(fuwari)
ご教授ください。VBA超初心者です。
ユーザーフォームを作成し、フォーム上にフレームがあります。フレームの中にはオプションボタン1とオプションボタン2を配置しています。
オプションボタン1を選択したときに図形の円をセルA1に、オプションボタン2を選択するとA1が消えA2に図形の円を挿入したいのですが、うまく行きません。
シェイプを移動する、ではだめですか? シェイプ.Top = Worksheets("Sheet1").Range("A2").Top
A1、A2どちらにも表示しない場合は シェイプ.Visible = False で。 (MARBIN)
こんなんでもOKですか?(ROUGE) '---- Private Sub OptionButton1_Click() Dim sp As Shape, r As Range Call sp_del Set r = Range("A1") Set sp = ActiveSheet.Shapes.AddShape _ (msoShapeOval, pc(r, 1), pc(r, 2), pc(r, 3), pc(r, 3)) End Sub Private Sub OptionButton2_Click() Dim sp As Shape, r As Range Call sp_del Set r = Range("A2") Set sp = ActiveSheet.Shapes.AddShape _ (msoShapeOval, pc(r, 1), pc(r, 2), pc(r, 3), pc(r, 3)) End Sub Private Sub sp_del() Dim sp As Shape For Each sp In ActiveSheet.Shapes If Not Intersect(Range("A1:A2"), _ 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
下が、私の記録したマクロです。
オプションボタン1で表示させたい設定
Sub Macro4()
'
' Macro4 Macro
' マクロ記録日 : 2008/1/29 ユーザー名 :
'
'
ActiveSheet.shapes.AddShape(msoShapeOval, 848.25, 256.5, 68.25, 61.5).Select Selection.ShapeRange.IncrementLeft -1.5 Selection.ShapeRange.IncrementTop -5.25 Selection.ShapeRange.Fill.Visible = msoTrue Selection.ShapeRange.Fill.Solid Selection.ShapeRange.Fill.ForeColor.SchemeColor = 65 Selection.ShapeRange.Fill.Transparency = 1# Selection.ShapeRange.Line.Weight = 0.75 Selection.ShapeRange.Line.DashStyle = msoLineSolid Selection.ShapeRange.Line.Style = msoLineSingle Selection.ShapeRange.Line.Transparency = 0# Selection.ShapeRange.Line.Visible = msoTrue Selection.ShapeRange.Line.ForeColor.SchemeColor = 64 Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255) End Sub
オプションボタン2で表示させたい設定
Sub Macro7()
'
' Macro7 Macro
' マクロ記録日 : 2008/1/29 ユーザー名 :
'
'
ActiveSheet.shapes.AddShape(msoShapeOval, 897#, 374.25, 64.5, 64.5).Select Selection.ShapeRange.IncrementLeft 29.25 Selection.ShapeRange.IncrementTop -124.5 Selection.ShapeRange.Fill.Visible = msoTrue Selection.ShapeRange.Fill.Solid Selection.ShapeRange.Fill.ForeColor.SchemeColor = 65 Selection.ShapeRange.Fill.Transparency = 1# Selection.ShapeRange.Line.Weight = 0.75 Selection.ShapeRange.Line.DashStyle = msoLineSolid Selection.ShapeRange.Line.Style = msoLineSingle Selection.ShapeRange.Line.Transparency = 0# Selection.ShapeRange.Line.Visible = msoTrue Selection.ShapeRange.Line.ForeColor.SchemeColor = 64 Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255) End Sub
どのように設定を変えたいのでしょうか。 提示されたコードでは分かりかねます。。。orz (ROUGE)
設定を変えたい部分は図の書式で、オートシェイブの書式設定で塗りつぶしの透明を100%にしています。また貼り付けたい場所は私のブック上でF6のセルです。同じセルの中に新規・継続という文字があり、オプションボタンを選択することにより、どちらかに○を付けたいのです。○を貼り付ける作業のみを記録したのが、上記のマクロです。すみません、説明が下手ですが、可能でしょうか。
>同じセルの中に新規・継続という文字があり とのことですので、微調整はご自身でされるしかないかと。 当方、MSPゴシック、11ポイント、左詰とし、以下でうまくいきました。 (ROUGE) '---- Private Sub OptionButton1_Click() Dim sp As Shape, r As Range, obj As Object Set obj = Selection Call sp_del Set r = Range("F6") Set sp = ActiveSheet.Shapes.AddShape _ (msoShapeOval, r.Left, pc(r, 2), pc(r, 3) * 1.8, 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("F6") Set sp = ActiveSheet.Shapes.AddShape _ (msoShapeOval, pc(r, 1) + 10, pc(r, 2), pc(r, 3) * 1.8, 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("F6"), _ 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
別セルならば、ぴったりできますよ。。。
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.