Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


11101 / 13644 ツリー ←次へ | 前へ→

【17918】3次元棒グラフをマクロで描くには カド 04/9/10(金) 12:32 質問[未読]
【17919】Re:3次元棒グラフをマクロで描くには IROC 04/9/10(金) 13:01 回答[未読]
【17948】Re:3次元棒グラフをマクロで描くには カド 04/9/10(金) 20:52 お礼[未読]
【17941】Re:3次元棒グラフをマクロで描くには ichinose 04/9/10(金) 18:24 発言[未読]
【17962】Re:3次元棒グラフをマクロで描くには カド 04/9/11(土) 9:36 お礼[未読]
【17963】Re:3次元棒グラフをマクロで描くには ichinose 04/9/11(土) 10:42 発言[未読]
【17964】Re:3次元棒グラフをマクロで描くには 追伸 ichinose 04/9/11(土) 10:48 発言[未読]
【17969】Re:3次元棒グラフをマクロで描くには 追伸 カド 04/9/11(土) 17:06 お礼[未読]
【17980】Re:3次元棒グラフをマクロで描くには 追伸 ichinose 04/9/11(土) 22:05 発言[未読]
【17987】Re:3次元棒グラフをマクロで描くには ち... ichinose 04/9/12(日) 0:44 発言[未読]
【18061】Re:3次元棒グラフをマクロで描くには ち... カド 04/9/14(火) 9:46 お礼[未読]
【18094】Re:3次元棒グラフをマクロで描くには ち... ichinose 04/9/15(水) 7:34 発言[未読]
【18105】Re:3次元棒グラフをマクロで描くには ち... カド 04/9/15(水) 13:46 お礼[未読]
【18107】Re:3次元棒グラフをマクロで描くには ち... カド 04/9/15(水) 16:55 お礼[未読]
【18108】Re:3次元棒グラフをマクロで描くには ち... カド 04/9/15(水) 17:54 お礼[未読]

【17918】3次元棒グラフをマクロで描くには
質問  カド  - 04/9/10(金) 12:32 -

引用なし
パスワード
   3次元の棒グラフをマクロで描きたいのですが、下記のマクロを実施すると、
棒の右側面の大きさが合いません。

どうすればよいか教えてください。

Sub Macro30()


'(x位置、y位置、幅、長さ)

  ActiveSheet.Shapes.AddShape(msoShapeCube, 50, 80, 15, 20).Select

  ActiveSheet.Shapes.AddShape(msoShapeCube, 50, 70 + 4, 15, 10).Select

End Sub

【17919】Re:3次元棒グラフをマクロで描くには
回答  IROC  - 04/9/10(金) 13:01 -

引用なし
パスワード
   いきなり3D図形を書かずに
四角を書いてから、3Dに変更してみて下さい。

【17941】Re:3次元棒グラフをマクロで描くには
発言  ichinose  - 04/9/10(金) 18:24 -

引用なし
パスワード
   ▼カド さん:
こんばんは。

>3次元の棒グラフをマクロで描きたいのですが、下記のマクロを実施すると、
>棒の右側面の大きさが合いません。
>
>どうすればよいか教えてください。
Adjustmentsオブジェクトの位置によって工夫しなければならないみたいですね!!

以下のコードを試してみて下さい。
'=========================================================
Sub Macro30()
'(x位置、y位置、幅、長さ)

  Call set_fund_shp(ActiveSheet.Shapes.AddShape(msoShapeCube, 50, 80, 15, 20))
  Call set_adj(ActiveSheet.Shapes.AddShape(msoShapeCube, 50, 70 + 4, 15, 10))
End Sub

上記とは違う標準モジュールに
'=================================================================
  Dim f_sz As Double 'widthとheightの小さい方のサイズ
  Dim adj As Double '調整値
  Dim l_u As Long '0:上端 1:左端
Sub set_fund_shp(shp As Shape)
  With shp
   If .Height <= .Width Then
    l_u = 0
    f_sz = .Height
   Else
    l_u = 1
    f_sz = .Width
    End If
   adj = .Adjustments.Item(1)
   End With
End Sub
'=====================================================================
Sub set_adj(shp As Shape)
  Dim s_l_u As Long
  Dim s_sz As Double
  With shp
   If .Height <= .Width Then
    s_l_u = 0
     s_sz = .Height
   Else
    s_l_u = 1
    s_sz = .Width
    End If
   If l_u <> s_l_u Then
    .Adjustments.Item(1) = f_sz * adj / s_sz
    End If
   End With
End Sub


もっともWidthが大きくなると(100とか200)他の事も考えなければなりませんが・・・。

取り合えず、確認してみて下さい。

【17948】Re:3次元棒グラフをマクロで描くには
お礼  カド  - 04/9/10(金) 20:52 -

引用なし
パスワード
   ▼IROC さん 回答ありがとうございます。

確かに言われている方法だとずれることはなさそうです。
ただ、図形に線が表示されないようですね。
線が出れば良いのですが。

【17962】Re:3次元棒グラフをマクロで描くには
お礼  カド  - 04/9/11(土) 9:36 -

引用なし
パスワード
   ▼ichinose さん:
回答ありがとうございます。

教えていただいたコードのままだとうまく行きますが、幅を変えると、
またもや、ずれてしまうようです。

  Call set_fund_shp(ActiveSheet.Shapes.AddShape(msoShapeCube, 50, 80, 15, 20))←15を20にしてみた
  Call set_adj(ActiveSheet.Shapes.AddShape(msoShapeCube, 50, 70 + 4, 15, 10))←15を20にしてみた

【17963】Re:3次元棒グラフをマクロで描くには
発言  ichinose  - 04/9/11(土) 10:42 -

引用なし
パスワード
   ▼カド さん:
おはようございます。

>
>教えていただいたコードのままだとうまく行きますが、幅を変えると、
>またもや、ずれてしまうようです。

Sub Macro30()
'(x位置、y位置、幅、長さ)

  Call set_fund_shp(ActiveSheet.Shapes.AddShape(msoShapeCube, 50, 80, 20, 30))
  Call set_adj(ActiveSheet.Shapes.AddShape(msoShapeCube, 50, 70 + 4, 20, 10))
End Sub

として、行ってみました。
結果、私の意図した図形表示はなされています。
提示したコードは、横方向の形を調整することだけを行っています。
よって、Widthの変更によるTopプロパティの調節はしていません。

Widthを変更すれば、Topも変更しないと隙間はできると思います。

【17964】Re:3次元棒グラフをマクロで描くには ...
発言  ichinose  - 04/9/11(土) 10:48 -

引用なし
パスワード
   さっきのコード、
Sub Macro30()
'(x位置、y位置、幅、長さ)

  Call set_fund_shp(ActiveSheet.Shapes.AddShape(msoShapeCube, 50, 80, 20, 30))
  Call set_adj(ActiveSheet.Shapes.AddShape(msoShapeCube, 50, 70 + 6, 20, 10))
End Sub
というようにTopプロパティを変更すれば、ピッタリきませんか?

【17969】Re:3次元棒グラフをマクロで描くには ...
お礼  カド  - 04/9/11(土) 17:06 -

引用なし
パスワード
   ▼ichinose さん:
回答ありがとうございます。

ずれるのは、高さ方向もですが、前面の幅の大きさが合わないですね。
やっぱりちょっと私の手には負えないようです。

【17980】Re:3次元棒グラフをマクロで描くには ...
発言  ichinose  - 04/9/11(土) 22:05 -

引用なし
パスワード
   ▼カド さん:
こんばんは。

回答ありがとうございます。

>ずれるのは、高さ方向もですが、前面の幅の大きさが合わないですね。
>やっぱりちょっと私の手には負えないようです。
うーん、微妙なずれがあるみたいですねえ!!

このズレ、Adjustmentが上端にあるか左端にあるかで出てきているみたいです。

私がチェックした限りでは、

ActiveSheet.Shapes.AddShape(msoShapeCube, 50, 80, 20, 30)

の場合、Width<Heightと言う関係から、Adjustmentが上端

ActiveSheet.Shapes.AddShape(msoShapeCube, 50, 70 + 6, 20, 10)

の場合、Width>Heightと言う関係から、Adjustmentは左端

何回かサンプリングした結果、

Width<Heightの関係が成立した場合、Adjustmentが上端

それ以外の場合、Adjustmentは左端

となっていました(あくまでもサンプリングの結果ですが)。

この結果から考えると、Widthが20の場合、Heightは、16以上であれば、
Adjustmentは上端で統一できますよね?

他のには、
この3Dの長方形をShapeの組合せで作ってしまう方法ですが、
若干、Shapeのスケールが違いますが、以下のコードを試してみて下さい。
但し、あまり小さいと全部表示できません。

'==================================================================
Sub test()
  Call mk_graph_pt(ActiveSheet, 50, 80, 15, 30)
  Call mk_graph_pt(ActiveSheet, 50, 70, 15, 10)
End Sub
'======================================================================
Function mk_graph_pt(sht As Worksheet, x As Double, y As Double, w As Double, h As Double)
  Dim px(1 To 4) As Double
  Dim py(1 To 4) As Double
  Dim para1 As Shape
  Dim para2 As Shape
  Dim para3 As Shape
  Dim pi As Double '円周率
  Dim g_nm()
  pi = WorksheetFunction.pi()
  px(1) = x + w + w * 0.6 * Cos(4 / 5 * pi): py(1) = y + w * 0.6 * Sin(4 / 5 * pi)
  px(2) = x + w: py(2) = y
  px(3) = x + w: py(3) = y + h
  px(4) = x + w + w * 0.6 * Cos(4 / 5 * pi): py(4) = y + w * 0.6 * Sin(4 / 5 * pi) + h
  Set para1 = Mk_Parallelogram(sht, px(), py(), 22)
  px(1) = x: py(1) = y
  px(2) = x + w: py(2) = y
  px(3) = x + w + w * 0.6 * Cos(4 / 5 * pi): py(3) = y + w * 0.6 * Sin(4 / 5 * pi)
  px(4) = x + w * 0.6 * Cos(4 / 5 * pi): py(4) = y + w * 0.6 * Sin(4 / 5 * pi)
  Set para2 = Mk_Parallelogram(sht, px(), py())
  Set para3 = sht.Shapes.AddShape(msoShapeRectangle, x + w * 0.6 * Cos(4 / 5 * pi), y + w * 0.6 * Sin(4 / 5 * pi), w, h)
  g_nm() = Array(para1.Name, para2.Name, para3.Name)
  Set mk_graph_pt = sht.Shapes.Range(g_nm()).Group
End Function
'======================================================================
Function Mk_Parallelogram(sht As Worksheet, p_x() As Double, p_y() As Double, Optional cl As Long = 9) As Shape
  Dim para As Shape '四辺形のShapeオブジェクト
  With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, p_x(1), p_y(1))
   For idx = 2 To 4
     .AddNodes msoSegmentLine, msoEditingAuto, p_x(idx), p_y(idx)
     Next idx
   .AddNodes msoSegmentLine, msoEditingAuto, p_x(1), p_y(1)
   Set Mk_Parallelogram = .ConvertToShape
   With Mk_Parallelogram
      .Fill.ForeColor.SchemeColor = cl
      .Fill.Visible = msoTrue
      .Fill.Solid
      End With
   End With
End Function

高さの調整は、単純で上記のコードの方がよいと思いますが・・・。

まっ、試してみて下さい。

【17987】Re:3次元棒グラフをマクロで描くには ...
発言  ichinose  - 04/9/12(日) 0:44 -

引用なし
パスワード
   以下のコードで小さいサイズも作成できそうです。

'===============================================================
Sub test()
  With Range("b1")
    Call mk_graph_pt(ActiveSheet, .Left, 80, 15, 30)
    Call mk_graph_pt(ActiveSheet, .Left, 74, 15, 6)
    Call mk_graph_pt(ActiveSheet, .Left, 54, 15, 20)
    End With
End Sub
'=========================================================================
Function mk_graph_pt(sht As Worksheet, x As Single, y As Single, w As Single, h As Single)
  Dim px(1 To 4) As Single
  Dim py(1 To 4) As Single
  Dim para1 As Shape
  Dim para2 As Shape
  Dim para3 As Shape
  Dim pi As Single '円周率
  Dim g_nm()
  pi = WorksheetFunction.pi()
  If w < 15 Or h < 10 Then
   hh = h * 10
   ww = w * 10
   px(1) = 150 + ww + ww * 0.8 * Cos(4 / 5 * pi): py(1) = 100 + ww * 0.8 * Sin(4 / 5 * pi)
   px(2) = 150 + ww: py(2) = 100
   px(3) = 150 + ww: py(3) = 100 + hh
   px(4) = 150 + ww + ww * 0.8 * Cos(4 / 5 * pi): py(4) = 100 + ww * 0.8 * Sin(4 / 5 * pi) + hh
   Set para1 = Mk_Parallelogram(sht, px(), py(), 22)
   With para1
    .Width = .Width / 10
    .Height = .Height / 10
    .Left = x + w + w * 0.8 * Cos(4 / 5 * pi)
    .Top = y
    End With
   px(1) = 150: py(1) = 100
   px(2) = 150 + ww: py(2) = 100
   px(3) = 150 + ww + ww * 0.8 * Cos(4 / 5 * pi): py(3) = 100 + ww * 0.8 * Sin(4 / 5 * pi)
   px(4) = 150 + ww * 0.8 * Cos(4 / 5 * pi): py(4) = 100 + ww * 0.8 * Sin(4 / 5 * pi)
   Set para2 = Mk_Parallelogram(sht, px(), py())
   With para2
    .Width = .Width / 10
    .Height = .Height / 10
    .Left = x + w * 0.8 * Cos(4 / 5 * pi)
    .Top = y
    End With
  Else
   px(1) = x + w + w * 0.8 * Cos(4 / 5 * pi): py(1) = y + w * 0.8 * Sin(4 / 5 * pi)
   px(2) = x + w: py(2) = y
   px(3) = x + w: py(3) = y + h
   px(4) = x + w + w * 0.8 * Cos(4 / 5 * pi): py(4) = y + w * 0.8 * Sin(4 / 5 * pi) + h
   Set para1 = Mk_Parallelogram(sht, px(), py(), 22)
   px(1) = x: py(1) = y
   px(2) = x + w: py(2) = y
   px(3) = x + w + w * 0.8 * Cos(4 / 5 * pi): py(3) = y + w * 0.8 * Sin(4 / 5 * pi)
   px(4) = x + w * 0.8 * Cos(4 / 5 * pi): py(4) = y + w * 0.8 * Sin(4 / 5 * pi)
   Set para2 = Mk_Parallelogram(sht, px(), py())
   End If
  Set para3 = sht.Shapes.AddShape(msoShapeRectangle, x + w * 0.8 * Cos(4 / 5 * pi), y + w * 0.8 * Sin(4 / 5 * pi), w, h)
  g_nm() = Array(para1.Name, para2.Name, para3.Name)
  Set mk_graph_pt = sht.Shapes.Range(g_nm()).Group
End Function
'=======================================================================
Function Mk_Parallelogram(sht As Worksheet, p_x() As Single, p_y() As Single, Optional cl As Long = 9) As Shape
  On Error Resume Next
  Dim para As Shape '四辺形のShapeオブジェクト
  With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, p_x(1), p_y(1))
   For idx = 2 To 4
     .AddNodes msoSegmentLine, msoEditingAuto, p_x(idx), p_y(idx)
     Next idx
   .AddNodes msoSegmentLine, msoEditingAuto, p_x(1), p_y(1)
   Set Mk_Parallelogram = .ConvertToShape
   With Mk_Parallelogram
      .Fill.ForeColor.SchemeColor = cl
      .Fill.Visible = msoTrue
      .Fill.Solid
      End With
   End With
End Function

【18061】Re:3次元棒グラフをマクロで描くには ...
お礼  カド  - 04/9/14(火) 9:46 -

引用なし
パスワード
   ▼ichinose さん:
何度もありがとうございます。

確認させていただきましたが、幅を変えると棒グラフの真ん中の図形の形が
ちょっと崩れるようです。


'===============================================================
Sub test()
  With Range("b1")
    Call mk_graph_pt(ActiveSheet, .Left, 80, 15, 30)←15を25に変えてみた。
    Call mk_graph_pt(ActiveSheet, .Left, 74, 15, 6))←15を25に変えてみた。

    Call mk_graph_pt(ActiveSheet, .Left, 54, 15, 20)
)←15を25に変えてみた。
    End With
End Sub

【18094】Re:3次元棒グラフをマクロで描くには ...
発言  ichinose  - 04/9/15(水) 7:34 -

引用なし
パスワード
   ▼カド さん:
おはようございます。再々投稿です。
理由は、後述します。


>何度もありがとうございます。
いえいえ、勉強になります・・・。
うーん、やっぱり、0.75を考慮しないと駄目ですねえ!!

それと小さい四角が作れないんです・・・。
そこで指定のWidthは、下限を15に限定してみたものを作って投稿しましたが、
不満だったので、再投稿です。

以下のコードは、
新規ブックを作成し、そのアクティブシートのセルA1に
作成する直方体のWidth(実際には、正面に作成される長方形のWidth)がランダム値として入力されます。

又、
セルB1〜セルK6にサンプルデータを作成し、その値に応じたグラフもどきを
B列〜K列の30行目から作成します。


以下のコードを新規ブックの標準モジュールにコピーして試してみて下さい。

'=======================================================================
Sub test()
  Dim h As Single
  Dim s As Single
  If ActiveWorkbook.Name <> ThisWorkbook.Name Then
    ActiveWorkbook.Close False
    End If
  Workbooks.Add
  Cells(1, 1).Value = Int(Rnd() * 35) + 3
  Call sampledata
  For idx = 2 To 11
  With Cells(31, idx)
    h = 0
    For jdx = 6 To 1 Step -1
     s = Cells(jdx, idx).Value
     h = h + Cells(jdx, idx).Value
     Call mk_graph_pt(ActiveSheet, .Left, .Top - h, Cells(1, 1).Value, s)
     Next
    End With
  Next
End Sub
'========================================================================
Function mk_graph_pt(sht As Worksheet, x As Single, y As Single, w As Single, h As Single)
'棒グラフ要素を作成する
'input : sht 作成するワークシート
'    x,y,w,h
  Dim px(1 To 4) As Single
  Dim py(1 To 4) As Single
  Dim para1 As Shape
  Dim para2 As Shape
  Dim para3 As Shape
  Dim pi As Single '円周率
  Dim g_nm()
  pi = WorksheetFunction.pi()
  Set para1 = sht.Shapes.AddShape(msoShapeRectangle, x, y, w, h)
  With para1
   px(1) = .Left + .Width: py(1) = .Top
   px(2) = px(1) + Int((.Width * 0.65 * Cos(-1 / 7 * pi)) / 0.75) * 0.75
   py(2) = py(1) + Int((.Width * 0.65 * Sin(-1 / 7 * pi)) / 0.75) * 0.75
   px(3) = px(2): py(3) = py(2) + .Height
   px(4) = .Left + .Width: py(4) = .Top + .Height
   Set para2 = Mk_Parallelogram(sht, px(), py(), 22)
   px(1) = .Left: py(1) = .Top
   px(2) = para2.Left + para2.Width - .Width
   py(2) = para2.Top
   px(3) = para2.Left + para2.Width
   py(3) = para2.Top
   px(4) = .Left + .Width
   py(4) = .Top
   Set para3 = Mk_Parallelogram(sht, px(), py())
   End With
  g_nm() = Array(para1.Name, para2.Name, para3.Name)
  Set mk_graph_pt = sht.Shapes.Range(g_nm()).Group
End Function
'=========================================================================
Function Mk_Parallelogram(sht As Worksheet, p_x() As Single, p_y() As Single, Optional cl As Long = 9) As Shape
'四角形を作成する
'input sht:ワークシートオブジェクト
'   p_x(),p_y()---4点の座表の入った配列
'   cl ----カラーインデックス
  On Error Resume Next
  Dim para As Shape '四辺形のShapeオブジェクト
  Dim plus As Single
  plus = 0
  Do
   With sht.Shapes.BuildFreeform(msoEditingAuto, p_x(1), p_y(1))
    For idx = 2 To 4
      .AddNodes msoSegmentLine, msoEditingAuto, p_x(idx) + plus, p_y(idx) + plus
      Next idx
    .AddNodes msoSegmentLine, msoEditingAuto, p_x(1), p_y(1)
    Err.Clear
    ret = 0
    Set Mk_Parallelogram = .ConvertToShape
    ret = Err.Number
    If ret <> 0 Then
      plus = plus + 20
    ElseIf ret = 0 Then
      If Mk_Parallelogram.Nodes.Count < 4 Then
       ret = 1
       Mk_Parallelogram.Delete
       plus = plus + 20
      Else
       If plus > 0 Then
         With Mk_Parallelogram
          For idx = 2 To 4
           .Nodes.SetPosition idx, p_x(idx), p_y(idx)
           Next
          End With
         End If
       Exit Do
       End If
      End If
    End With
   Loop
  With Mk_Parallelogram
    .Fill.ForeColor.SchemeColor = cl
    .Fill.Visible = msoTrue
    .Fill.Solid
    End With
End Function
'=====================================================================
Sub sampledata()
  For idx = 1 To 6
   For jdx = 2 To 11
     Cells(idx, jdx) = Int(Rnd() * 40) + 1
     Next
   Next
End Sub


再々投稿したのは、

1.小さい四角が作れなかったので困ってたんですが、それを可能にしため・・・。

2.上記のコードは、コードを実行するたびに新規ブックを作成しています。
 同一シートに図形の削除・作成を繰り返すと強制終了が発生したためです。
 メモリの問題かどうかは不明ですが。
 上記のコードの場合、Book100を超えて繰り返しても正常に作動しています。


以上です。確認して下さい。

【18105】Re:3次元棒グラフをマクロで描くには ...
お礼  カド  - 04/9/15(水) 13:46 -

引用なし
パスワード
   ▼ichinose さん:
回答ありがとうございます。

今度こそうまくいったようです。
内容のすべては現時点では把握できませんが、少しずつ勉強させて
いただきます。

あと、このような棒グラフで、棒の積み上げ数が3個の場合に、
それぞれの棒グラフに、下から青、黄、赤と色を付けたいのですが、
どのようにすればよいのでしょうか?

特に、一つずつのオブジェクト(四角形)に移動していく方法が(For Each?)
判りません。

【18107】Re:3次元棒グラフをマクロで描くには ...
お礼  カド  - 04/9/15(水) 16:55 -

引用なし
パスワード
   >あと、このような棒グラフで、棒の積み上げ数が3個の場合に、
>それぞれの棒グラフに、下から青、黄、赤と色を付けたいのですが、
>どのようにすればよいのでしょうか?

上記の件、質問内容がだんだん複雑になってきたので、別途改めて
質問します。

今回の件は、これで終わりにしたいと思います。

PS
もちろん、そんなの簡単だから、ここで回答するよというので
あれば、それに越したことはありませんが。

【18108】Re:3次元棒グラフをマクロで描くには ...
お礼  カド  - 04/9/15(水) 17:54 -

引用なし
パスワード
   とりあえずこんな感じで色付けは出来ましたが、棒グラフの値を表示する必要
があるなど、どんどん要求事項が増えてきて、手に負えなくなってきたので、
やはりエクセルのグラフ機能を使うことにしました。

色々とありがとうございました。

(追伸)
そもそも、どうしてこういうことを始めたかというと、エクセルで書いた
3Dの棒グラフはグラフエリアの高さを極端に小さくすると、幅が勝手に
小さくなって、どうしても広くすることが出来ないという問題があるからです。
2Dのグラフならこんな問題は無いのですが。


今回は3Dで高さの大きいグラフを書いて、ビットマップとして高さを
小さくすることで対処することにしました。

Dim 図形 As Shape

Count = 0
  For Each 図形 In ActiveSheet.Shapes

      図形.Select
     If Count Mod 3 = 0 Then '3で割った余り

      Selection.ShapeRange.Fill.ForeColor.SchemeColor = 15

     End If
    
     If Count Mod 3 = 1 Then

      Selection.ShapeRange.Fill.ForeColor.SchemeColor = 13

     End If
    
     If Count Mod 3 = 2 Then

      Selection.ShapeRange.Fill.ForeColor.SchemeColor = 14

     End If
     Count = Count + 1

  Next

11101 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free