• ベストアンサー

エクセル上にシェイプで二重丸を書くには

マクロを使って、エクセルのワークシート上に外半径Rの円を描いて、同心の内半径rの円を描きます。(ドーナツの形) Rやrはセルで指定した数値を取り込みます。 この2円の間を黄色で塗りつぶしたいのですが、できますか? Worksheets(1).Shapes.AddShape(msoShapeDonut, XC - RO, YC - RO, RO * 2, RO * 2).Select でドーナツを書くことはできましたが、内円の半径を自由に設定できないので悩んでいます。 Worksheets(1).Shapes.AddShape(msoShapeOval, XC - RO, YC - RO, RO * 2, RO * 2).Select で外円を描いて、黄色で塗りつぶしておいて Worksheets(1).Shapes.AddShape(msoShapeOval, XC - RI, YC - RI, RI * 2, RI * 2).Select で内円を描いて、白で塗りつぶせばいいのですが、内円の中は透過にしたいのです。 普通に透過にしてしまうと下の黄色が出てしまいます。 方法がわかれば「マクロの記録」を使ってなんとかなると思いますが、シェイプに慣れている方にヒントだけでも教えて頂ければありがたいです。

質問者が選んだベストアンサー

  • ベストアンサー
  • xls88
  • ベストアンサー率56% (669/1189)
回答No.3

内円調整ハンドルはなかったですか? 0.5で全円になります。 With ActiveSheet.Shapes   .AddShape(msoShapeDonut, 10, 10, 200, 200).Adjustments.Item(1) = 0.2 End With

aperun8
質問者

お礼

ありがとうございます。 No.1 様の線の太さを縮尺をかけて作る方法で一応望んでいた図が描けたのですが、Adjustments.Item(1)を使うほうがスマートですね。 Adjustments.Item(1) は着色部の厚さ/2Rで作ればいいんですね。 このハンドルを見落としていました。 まだまだ勉強が足りない・・ シェイプでできないことはない(?)みたいなことを聞いたことがあるので、もっと勉強します。 皆さんありがとうございました。

その他の回答 (2)

  • web2525
  • ベストアンサー率42% (1219/2850)
回答No.2

出来るかと思ったけど、オートシェイプの書式設定変更はマクロの記録で記録できないようでした。 線の太さも、マクロ中での変更が出来るのかどうかも分かりませんでいたごめんなさい。

aperun8
質問者

お礼

ありがとうございます。 Selection.ShapeRange.Line.Weight = 5.5 とかで設定はできるようですよ。 厳密な意味でのCADのような正確さは必要ないので .Line.Weight を操作して描画してみます。

  • web2525
  • ベストアンサー率42% (1219/2850)
回答No.1

ちょっと前の相談で似たようなものがあったけど、作画の線色を黄色にして円の線の太さを大きくする事で対応できるのでは? 必ず同心円になるし、ただ線の太さを変化させたときに図形の大きさが変化してしまうのでそのあたりの計算が難しいかとは思うけど。

aperun8
質問者

お礼

お答えいただきましてありがとうございます。 過去の質問の捜し方が悪かったのか同じような質問をしてしまっていたらすみません。 なるほど、線の太さで対処するんですね。 ただ、図形が管の断面を表していて、その下に箱状の桁を描きます。 その箱も縮尺をかけて描いているので、管と箱のスケールがなるべく正確に表示されるようにしたいんですが・・ お答えを元にもう少し考えて見ます。 ちなみにこちらのPCは、 OS Win XP SP3、Office Excel 2003 SP3です。

関連するQ&A

  • ShapeのVBAの中での取り扱い

    ShapeのVBAの中での取り扱いに関して、サジェスチョン願います。 Shapeに文字が書き込まれていない段階で、選択して文字を読み込み判定しようとするとエラーとなります。 下記のVBAでは、5番目のShapeが該当します。 このエラーを防ぐためには、On Error Resume Nextが有効ですが、他の方法を探しています。例えば、charactor=trueみたいなもの。 ----- Sub Shapeの調査() Dim nametemp(10) As String Dim temp As Integer Dim i As Integer Dim aaa As Variant 'On Error Resume Next ActiveSheet.Shapes.AddShape(msoShapeRectangle, 50, 50, 50, 50).Select ActiveSheet.Shapes.AddShape(msoShapeOval, 100, 100, 50, 50).Select ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 150, 150, 50, 50).Select ActiveSheet.Shapes.AddShape(msoShapeRectangle, 200, 200, 50, 50).Select ActiveSheet.Shapes.AddShape(msoShapeOval, 250, 250, 50, 50).Select temp = ActiveSheet.Shapes.Count For i = 1 To temp ActiveSheet.Shapes(i).Select nametemp(i) = ActiveSheet.Shapes(i).Name Next For i = 1 To temp / 2 + 1 '4つのshapeに対し、文字を書き込もうとする ActiveSheet.Shapes(nametemp(i)).Select Selection.Characters.Text = "" Next For i = 1 To temp / 2 '3つに対して、文字を書き込む ActiveSheet.Shapes(nametemp(i)).Select Selection.Characters.Text = "zzzzz" Next For i = 1 To temp ActiveSheet.Shapes(nametemp(i)).Select aaa = Selection.Characters.Text '<--5番目のShapeに対し If aaa = "zzzzz" Then MsgBox (aaa)'<--errorとなる。 Next End Sub

  • 円弧の描画について

    エクセルのワークシート上に2点(x1,y1)、(x2,y2)の座標があり、半径がrと決まっている場合に、(x1,y1)を始点、(x2,y2)を終点とする半径rの円弧を描きたいのですが、VBAで教えていただけますでしょうか? 例えばエクセルのワークシート上に2点(600,400)と(500,300)という座標があります。この座標は、 Dim ShapeA As Shape, ShapeB As Shape Set ShapeA = ActiveSheet.Shapes.AddShape _ (msoShapeOval, 600, 400, 2, 2) Set ShapeB = ActiveSheet.Shapes.AddShape _ (msoShapeOval, 500, 300, 2, 2) というコードでワークシート上に描いています。 この2点をそれぞれ始点、終点として、半径100の円弧を描く方法を考えているのですが、 VBA初心者の為、困っています。VBAで円弧を描く方法がありましたら是非教えていただきたく お願い致します。 よろしくお願い致します。

  • Office VBAについて

    OFFICE2007のプログラムをググったところ 下記のような表記が見つかりました。 ActiveSheet.Shapes.AddShape _ (msoShapeOval, 400.75, 110.75, 30.25, 10.5).Select Selection.ShapeRange.Fill.Visible = msoFalse Selection.ShapeRange.Fill.Transparency = 0# ここで質問ですが、Selection.ShapeRange.Fill.Transparencyの0#とはなんでしょうか。 またAddShapeの中の数値に#を入れているパターンもありました。 いろいろ探したのですが見つかりませんので教えてください。

  • エクセルで線の太さと色を変えるマクロ

    マクロ初心者です。ご教示願います。 エクセルのマクロで選択した任意のセルに●→を引くマクロを組みましたが、 線の太さと、色を変えるコードをどこにどう入れたらいのか教えてください。 Sub 線を引く() Dim TP, LF, WD TP = Selection.Top + (Selection.Height / 2) LF = Selection.Left WD = Selection.Width ActiveSheet.Shapes.AddShape(msoShapeOval, LF, TP - 3, 6, 6).Select ActiveSheet.Shapes.AddLine(LF + 6, TP, LF + WD, TP).Select

  • エクセルのVBAのことで

    以下のVBAを実行するとテキストボックスの"あ"という文字で円を描くことができます。 Sub test1() pai = 3.14159 r = 100 Worksheets("sheet1").Activate For s = 0 To 360 Step 15 rd = s / 180 * pai ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _ 200 + r * Sin(rd), 50 + r - r * Cos(rd), 20, 20).Select Selection.Characters.Text = "あ" Selection.ShapeRange.Fill.Visible = msoFalse Selection.ShapeRange.Line.Visible = msoFalse Next s End Sub この円の半分の半径の円を元の円とドーナツ型(◎)になるように描くにはどのようなスクリプトにすればいいのでしょうか?

  • エクセルVBA オートシェイプを操作したいです

    エクセルでセルの入力内容によって楕円をオートシェイプで出現させたいと思います。 http://oshiete1.goo.ne.jp/qa809742.htmlで見つかったものを参考にし、 Private Sub worksheet_Activate() Dim Shp As Shape Set P11 = Range("P11") If P11 Is Nothing Then Exit Sub If P11.Value = 1 Then For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N14:N15")) Is Nothing Then Shp.Delete End If Next Shp With ActiveSheet.Range("N14:N15") ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _ Left:=.Left,TOP:=.TOP,Width:=.Width,Height:=.Height).Select Selection.ShapeRange.Fill.Visible = msoFalse End With Range("N14").Select Else For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N14:N15")) Is Nothing Then Shp.Delete End If Next Shp End If If P11.Value = 2 Then For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N16")) Is Nothing Then Shp.Delete End If Next Shp With ActiveSheet.Range("N16") ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _ Left:=.Left, TOP:=.TOP, Width:=.Width, Height:=.Height).Select Selection.ShapeRange.Fill.Visible = msoFalse End With Range("N16").Select Else For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N16")) Is Nothing Then Shp.Delete End If Next Shp End If End Sub とつなげて見ました。 動くには動くのですが、データ元のセルがP11からT30と100セルあり、さらにP11に入力されるデータが1,2,3,4の4種類、AQ11に5,6,7,8,9の5種類などと、ばらばらです。 P11に1が入力されるとN14:N15(結合されています)に円が入り、2が入力されるとN16に円が入る。 Q11に5が入力されるとR13に円が入り、6が入力されるとR14:R15に円が入る・・・・のようにしたいのです。 一生懸命、セルNo.を打ち込んでいたら、 「コンパイルエラー:プロシージャが大きすぎます」とエラーが出てしまいました。 ループさせればよいのだろうと試してみたのですが、元のセルの指定方法や、オートシェイプの出現させるせるの指定方法がわかりません。 どのようにすれば、データー元の範囲を指定して、それに対応したセルにオートシェイプを出現させる事が出来るようになるでしょうか。 お知恵を貸していただけないでしょうか。よろしくお願い致します。

  • 図形を作成するマクロ

    Sub test() ActiveSheet.Shapes.AddShape(msoShapeOval, Selection.Left,Selection.Top, 72, 72).Select End Sub アクティブセルの左上に合わせて円を作成するマクロですが。 "Selection"のところに"x"という変数を用いる場合は、どのような宣言が必要になるでしょうか? ちなみに以下ではエラーになりました。 x = Range(ActiveCell.Address)

  • VBAでは角度はどっち回りですか?

    VBAでインボリュート曲線を描画するプログラムを書いたのですがなぜか時計回りになってしまいます。 自分は角度は3時の方向から反時計回りで増えていくと思っているのですがVBAでは逆回転なのでしょうか。 どっち回りか教えてください。 参考に作ったプログラムを書きます Sub インボリュート() '---------変数の宣言 Dim x1 As Double Dim y1 As Double Dim x2 As Double Dim y2 As Double Dim pai As Double Dim R As Integer '半径 Dim L As Double '-----値を初期設定 R = 50    L = 0 pai = 3.1415926535897 For θ = 0 To 3 * pai Step (pai / 1000) L = θ * R x1 = R * Cos(θ) y1 = R * Sin(θ) x2 = x1 + L * Cos(θ + 3 / 2 * pai) y2 = y1 + L * Sin(θ + 3 / 2 * pai) '---------シート上に図形を描画する ActiveSheet.Shapes.AddShape msoShapeOval, 500 + x1, 500 + y1, 1, 1 ActiveSheet.Shapes.AddShape msoShapeOval, 500 + x2, 500 + y2, 1, 1 Next θ End Sub ちなみにExcel2000です

  • Word2010 VBAでオブジェクトに文字の効果

    Word2010のVBAで作成するオートシェイプに文字を入力し、その文字に文字の効果を付けたいです。 付けたい効果は「ワードアートのスタイル」の「文字の効果」内にある「変形」の「四角」です。 Sub 図形() Dim 丸 As Shape Set 丸 = ActiveDocument.Shapes.AddShape(msoShapeOval, 1, 1, 60, 60) 丸.Select 丸.TextFrame.TextRange = "文字" 'この部分です。Excelではこれで出来たのですがWordだと書き方が違うのでしょうか? Selection.ShapeRange.TextEffect.PresetShape = msoTextEffectShapePlainText End Sub よろしくお願いいたします。

  • エクセル。マクロの記録で出来たVBAを書き直したい。

    エクセル2000(OSはWindows2000)でマクロの記録を行いました。 四角形を出してA1セルにリンクさせフォント等の設定をしたものです。 Sub Macro5() ActiveSheet.Shapes.AddShape(msoShapeRectangle, 200#, 100#, 140#, 80#). _ Select ExecuteExcel4Macro "FORMULA(""=R1C1"")" With Selection.Font .Name = "Century Gothic" .FontStyle = "太字" .Size = 72 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With Selection.ShapeRange.Fill.Visible = msoFalse Selection.ShapeRange.Fill.Transparency = 0# 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 = msoFalse End Sub これを、実際には四角形をセレクトしないで実行させたいのです。 With ActiveSheet.Shapes.AddShape~ End With といった形になるのでしょうが、どうもうまく出来ません。 ご教示いただければ幸いです。

専門家に質問してみよう