[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『グラフのプロットエリアを任意のセルに合わせたい』（まき）
Excel2003, Vista
いつも色々参考にさせて頂いております。
さて、現在４軸のグラフをマクロで作ろうとしており、１軸で２～４軸を変数変換させて グラフは問題無く出来ました。２～４軸を１軸の左側に項目名と出したと考えており、 その為にPlotAreaをセルに合わせたいと色々行っていますが、上手に出来ないのでご伝授 をお願い致します。過去に有った http://www.excel.studio-kazu.jp/kw/20050725174254.html を参考にChartエリアはセルに合わせて出来ました。分かりやすい様にシートのrowを15に 設定して.PlotArea.Topを色々変えてみましたが、どうしてもセルに合いません。出来れば、 PlotArea.Height(Y軸)を８セル(15*8=120)にしたいのですが、こっちを直すと下がずれた りで、お手上げ状態です。ちなみに現行のVBAは(抜粋)は次の通りです。複数個のグラフを を１度に書くので、奇数時には左側、偶数値には右側と配置する様にしました。
－－－－－－－－－－－－－－－(上記省略)－－－－－－－－－－－－－
Sheets("グラフ").Activate
If 回数 Mod 2 <> 0 Then '奇数時
整数 = Application.RoundUp(回数 / 2, 0) + Application.RoundDown(回数 / 2, 0) * 21 + 1
Set グラフ範囲 = Sheets("グラフ").Range("J" & 整数 & ":N" & 整数 + 20)
Else '偶数時
整数 = Application.RoundUp(回数 / 2, 0) + (Application.RoundUp(回数 / 2, 0) - 1) * 21 + 1
Set グラフ範囲 = Sheets("グラフ").Range("X" & 整数 & ":AB" & 整数 + 20)
End If
Set グラフChart = Sheets("グラフ").ChartObjects.Add( _
グラフ範囲.Left, グラフ範囲.Top, グラフ範囲.Width, グラフ範囲.Height)
With グラフChart.Chart
.ChartType = xlLine 'グラフの種類
.SetSourceData Source:=Sheets("temp").Range(ラベル範囲, "F" & 始行 + 1 & _
":" & 完了 & 最終行 & ""), PlotBy:=xlColumns
.SeriesCollection(1).XValues = x軸
.PlotArea.Top = 160 'プロットエリアの上の位置
.PlotArea.Width = 240 '1列あたり、約80
.PlotArea.Height = 144 '1rowあたり、15ピクセル
.PlotArea.Border.Weight = 2
.PlotArea.Border.LineStyle = 0
.PlotArea.Interior.ColorIndex = xlNone
－－－－－－－－－－－－－－－(以下省略)－－－－－－－－－－－－－
お手数ですが、よろしくお願い申し上げます。
なかなか解答がつかないようですが...。 と言うのも、コードだけ記載されても、同じように再現できないからだと思います。 元のグラフのデータレイアウトなどとともに、どの種類のグラフなのか等も記載されると、 見ている人も再現できるのではなかろうか？ と思います。
ほとんど山勘な上、確認とってませんが。 （確認を取っていないと言うより、なさりたい事が解ってません。） プロットエリアでなく、図形としてのグラフで扱ったらどうでしょうか？ グラフをマウスで選択した時に、黒い四角点で選択表示されるのではなく、 白い丸点で、選択表示されるオブジェクトの事。 （図形描画ツールバーの左の方にある、左斜め上の矢印アイコンで （グラフを選択した時のオブジェクト。） 表現が難しいのでこんな表現になってます。 BJ
>コードだけ記載されても、同じように再現できないからだと思います。 正にこれが大きい原因ですね！！
私は、グラグはあまり使わないので簡単なグラフで試して見ました。
新規ブックにて試してみてください。
標準モジュールに
'=====================================================================================
Sub sample()
Dim obj As Range
Dim plot As Range
Set obj = Range("a10:j23")
Set plot = Range("b12:i20")
Call mk_sample_data
Rows("1:30").RowHeight = 15
Columns("A:M").ColumnWidth = 9
MsgBox "ご覧のデータでグラフを" & obj.Address & "に又、グラグ軸を" & plot.Address & "のセル範囲にあわせて作成します"
Call mk_graph(Range("a1:b8"), obj, plot)
End Sub
'=====================================================================================
Sub mk_sample_data()
Range("a1:b8").Value = Evaluate("{""氏名"",""身長(Cm)"";""a"",140;""b"",145;" & _
"""c"",135;""d"",130;""e"",160;""f"",155;""g"",170}")
End Sub
'======================================================================================
Sub mk_graph(ByVal c_dataarea As Range, ByVal c_objarea As Range, c_plotarea As Range)
Dim mychart As Chart
Dim ll As Double
Dim hh As Double
ll = c_plotarea.Left - c_objarea.Left
hh = c_plotarea.Top - c_objarea.Top
Application.Goto c_objarea
c_objarea.Select
With Charts.Add
.ChartType = xlColumnClustered
.SetSourceData Source:=c_dataarea, PlotBy:=xlColumns
Set mychart = .Location(Where:=xlLocationAsObject, Name:=c_objarea.Parent.Name)
With mychart.Parent
.Left = c_objarea.Left
.Top = c_objarea.Top
.Width = c_objarea.Width
.Height = c_objarea.Height
End With
With mychart.PlotArea
.Left = 0
.Top = 0
.Width = c_plotarea.Width
.Width = .Width + .Width - .InsideWidth
.Height = c_plotarea.Height
.Height = .Height + .Height - .InsideHeight
.Left = ll + .Left - .InsideLeft - mychart.ChartArea.Left
.Top = hh - .InsideTop + .Top - mychart.ChartArea.Top
End With
End With
End Sub
sampleを実行してみてください。 作成されたデータに対して、コードで表示されるようなグラフを作成します。
尚、plotというセル範囲に対して、十分余裕のあるobjというセル範囲を指定しないと 正しく作成されないので注意してください（単純にセル範囲が obj>=plotでは駄目な場合がありました）
大勢の方に考えてもらうには、サンプルが必要なのでこれを足がかりにできませんか？
ichinose
BJ様、 ichinose様
こんにちは、まきです。レスが遅れてしまい大変申し訳ございませんでした。
今回の説明が足りなくて申し訳ございませんでした。行いたい内容は、
Sheet2～数十シート目まで１日のlot_dataのcsvが貼り付けています。Sheet1には、menu
ボタンやlot_dataの代表項目の一覧表を表記しています。Sheet1に有る表からグラフに
したlot_noを選び、グラフにしたい項目値(ファームが立ち上がり)を選択し、各項目の
最大値を入れます。(自動入力も出来、選択されたlot_noの各項目の最大値を選ぶ)
各シートからグラフに出したい値のみをSheet("temp")にcopyして、ここからSheet("
グラフ")に４軸(最大)の折れ線グラフで書かせます。(将来６軸まで)
Sheet("グラフ")には、下記の様なレイアウトで選択されたsheet分書き込みます。
｜
｜
Sheet2 ｜ Sheet3
｜
｜
------------------------
｜
｜
Sheet4 ｜ Sheet5
｜
｜
多軸グラフは、２軸以降は変数を使い１軸グラフで最大４軸を作っております。故に
Ｙ軸に２～４軸目の目盛、数値、項目名と表記したい(グラフの左側)為に、PlotArea.Heightの上と下
をセルのRowの幅(案は８行)に合わせたいと思います。
BJ様 プロットエリアのみを図形(jpg等)にする事が出来るのでしょうか？もし可能であれば、 絵として貼り付け、Y軸その他をシートに表記すればいいので、出来る様な気がします。
ichinose様 サンプルを上げて頂き有り難うございました。動作させた所、高さも幅もセルに合わせ て記述出来ました。このVBAをベースに私のVBA(シートのボタン)に移しましたが、 ichinose様のサンプル通りの動きをしませんでした。(取りあえずTOPしか行っていませんが) (前と変わらない)修正後のVBA(長いのでグラフ部のみ)は、次の通りです。ちなみに、 ブレークポイントを入れて、数値が入っているかどうかをみましたが、数値は全部入っていました。
'グラフ作成
'グラフを制作する情報の収集
Dim hh As Double
Sheets("temp").Activate '作成するグラフの数を数える
With ActiveSheet
.Range("IV" & 始行).Select
Selection.End(xlToLeft).Select
グ数 = ActiveCell.Column - 5
完了 = Left(ActiveCell.AddressLocal(, False), 1) 'Columnｱﾄﾞﾚｽをｱﾙﾌｧﾍﾞｯﾄ値で取得
開始 = "F" '深度のdata場所
.Range("B65536").Select '最終行の検索
Selection.End(xlUp).Select
最終行 = ActiveCell.Row
ラベル範囲 = "F" & 始行 & ":" & 完了 & 始行 & ""
End With
x軸 = "=temp!R" & 始行 + 1 & "C2:R" & 最終行 & "C2"
'グラフシートへエリア選択
Sheets("グラフ").Activate
If 回数 Mod 2 <> 0 Then '奇数時
整数 = Application.RoundUp(回数 / 2, 0) + Application.RoundDown(回数 / 2, 0) * 21 + 1
Set グラフ範囲 = Sheets("グラフ").Range("J" & 整数 & ":N" & 整数 + 20)
Set プロット範囲 = Sheets("グラフ").Range("J" & 整数 + 5 & ":N" & 整数 + 13)
Else '偶数時
整数 = Application.RoundUp(回数 / 2, 0) + (Application.RoundUp(回数 / 2, 0) - 1) * 21 + 1
Set グラフ範囲 = Sheets("グラフ").Range("X" & 整数 & ":AB" & 整数 + 20)
Set プロット範囲 = Sheets("グラフ").Range("X" & 整数 + 5 & ":AB" & 整数 + 13)
End If
Set グラフChart = Sheets("グラフ").ChartObjects.Add( _
グラフ範囲.Left, グラフ範囲.Top, グラフ範囲.Width, グラフ範囲.Height)
With グラフChart.Chart
hh = .PlotArea.Top - .ChartArea.Top
.ChartType = xlLine 'グラフの種類
.SetSourceData Source:=Sheets("temp").Range(ラベル範囲, "F" & 始行 + 1 & _
":" & 完了 & 最終行 & ""), PlotBy:=xlColumns
.SeriesCollection(1).XValues = x軸
.Parent.Top = .ChartArea.Top
.PlotArea.Top = 0 'プロットエリアの上の位置
.PlotArea.Width = 240 '1列辺り、約80
.PlotArea.Height = 160 '1行当たり、15(20ピクセル)
.PlotArea.Top = hh - .PlotArea.InsideTop + .PlotArea.Top - .ChartArea.Top
.PlotArea.Border.Weight = 2
.PlotArea.Border.LineStyle = 0
.PlotArea.Interior.ColorIndex = xlNone
.HasDataTable = False
.ChartArea.Border.Weight = 2
.ChartArea.Border.LineStyle = 0
.ChartArea.Interior.ColorIndex = xlNone
.HasTitle = True
.ChartTitle.Characters.Text = "番号:" & 番号
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "経過時間(sec)"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "深度(m)"
.Axes(xlValue).AxisTitle.HorizontalAlignment = xlCenter
.Axes(xlValue).AxisTitle.VerticalAlignment = xlCenter
.Axes(xlValue).AxisTitle.Orientation = xlVertical
.Axes(xlCategory).HasMajorGridlines = False
.Axes(xlCategory).HasMinorGridlines = False
.Axes(xlValue).HasMajorGridlines = False
.Axes(xlValue).HasMinorGridlines = False
.Axes(xlValue).MinimumScaleIsAuto = True
.Axes(xlValue).MaximumScaleIsAuto = True
.Axes(xlValue).MinorUnit = 1
.Axes(xlValue).MajorUnit = 1
.Axes(xlValue).Crosses = xlMaximum
.Axes(xlValue).ReversePlotOrder = True
.Axes(xlValue).ScaleType = xlLinear
.Axes(xlValue).DisplayUnit = xlNone
.Axes(xlCategory).CrossesAt = 1
.Axes(xlCategory).TickLabelSpacing = 60
.Axes(xlCategory).TickMarkSpacing = 60
.Axes(xlCategory).AxisBetweenCategories = True
.Axes(xlCategory).ReversePlotOrder = False
.Legend.Top = 0 'グラフの凡例の場所(高さ）
If グ数 > 3 Then
.SeriesCollection(3).Border.ColorIndex = 10
End If
End With
始行 = 最終行 + 1
回数 = 回数 + 1
Loop
以上よろしくお願い致します。(まき)
御質問内容とは違いますが。。。 「最終的にはこんなのでも良いのかな？」と思ってみたりします。
↓コードを載せますが、コードはマクロの記録を切り張りした物なので あまり参考には成りません。
コードを実行して出来たデータと、それを元にして完成したグラフを見て イメージを掴んでもらうと良いと思います。 多くの部分は、今回コードが埋め込むデータ・配置などに 固有の値が直接入れてあります。
'------
Sub データ作成()
Dim shn As String
If MsgBox("データ作成を開始します。", vbOKCancel) = vbCancel Then
Exit Sub
End If
Sheets.Add
Range("A1:C6").Value = _
Evaluate("{""体重"",""身長"",""カロリー"";" & _
"64,160,2203;56.3,153,1778;" & _
"68.1,165,2317;72.3,170,2434 ;" & _
"76.6,175,2553}")
Range("A1:C6").Interior.ColorIndex = 35
If MsgBox("A1:C6のデータでグラフを作成します。" & vbLf & vbLf & _
"軸目盛を決定します｡ ", vbOKCancel) = vbCancel Then
Exit Sub
End If
Range("F9:H9").Value = Range("A1:C1").Value
Range("F2:H2").Value = Array(80, 180, 2700)
Range("F3:G8").Formula = "=F2-5"
Range("H3:H8").Formula = "=H2-200"
Range("F3:H8").Value = Range("F3:H8").Value
Range("I2:I8").Formula = _
"=TEXT(F2,""?0"")&"" ""&TEXT(G2,""??0"")&"" ""&TEXT(H2,""???0"")"
Range("I9").Value = "↑値ラベルの変わりに表示させたい様に設定"
Range("I10").Value = " 今は数式が入っています。"
Range("F2:H8").Interior.ColorIndex = 37
Range("I2:I8").Interior.ColorIndex = 34
If MsgBox("I2:I8が軸になるグラフを作成します。" & vbLf & vbLf & _
"軸用データを作成します。", vbOKCancel) = vbCancel Then
Exit Sub
End If
Range("E1:F1").Value = Array("Ｘ", "Ｙ")
Range("E2:E8").Value = 0.5
Range("E10").Value = "↑Ｘの値 0.5"
Range("E2:E8").Interior.ColorIndex = 39
If MsgBox("軸ラベル用にE2:F8の散布図をグラフに追加します。" & vbLf & vbLf & _
"A2:C6のデータを一つの軸で納まるように変換します。" & vbLf & _
"グラフ用データを作成します。", vbOKCancel) = vbCancel Then
Exit Sub
End If
Dim rng As Range
Range("A8:C8").Value = Range("A1:C1").Value
Range("A9:A13").Formula = "=A2"
Range("B9:B13").Formula = "=B2-100"
Range("C9:C13").Formula = "=(C2+500)/40"
Range("A14").Value = "↑A8:C13で折れ線グラフを作成"
Range("A8:C13").Interior.ColorIndex = 38
With Range("A8:C13,E2:F8")
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
End With
End Sub
Sub グラフ作成()
Dim shn As String, xlbl As Range, i As Long
shn = ActiveSheet.Name
If MsgBox("グラフを作成します。" & vbLf & vbLf & _
"A8:C13のデータで折れ線グラフを作成" & vbLf & _
"E2:F8のデータで作った散布図を追加" & vbLf & _
"後は、それっぽく見えるように整えます。", vbOKCancel) = vbCancel Then
Exit Sub
End If
shn = ActiveSheet.Name
With Charts.Add
.ChartType = xlLineMarkers
.SetSourceData Source:=Sheets(shn).Range("A8:C13"), PlotBy:=xlColumns
With .Legend
.AutoScaleFont = False: .Font.Name = "ＭＳ ゴシック": .Font.Size = 10
End With
With .Axes(xlCategory).TickLabels
.AutoScaleFont = False: .Font.Name = "ＭＳ ゴシック": .Font.Size = 10
End With
.Location Where:=xlLocationAsObject, Name:=shn
End With
' ★散布図を追加して､整える
With ActiveChart
With .SeriesCollection.NewSeries
.ChartType = xlXYScatter
.XValues = "=" & shn & "!R2C5:R8C5"
.Values = "=" & shn & "!R2C6:R8C6"
.MarkerBackgroundColorIndex = xlNone
.MarkerStyle = xlNone
.ApplyDataLabels ShowCategoryName:=True
With .DataLabels
.AutoScaleFont = False: .Font.Name = "ＭＳ ゴシック": .Font.Size = 10
.Position = xlLabelPositionLeft
End With
For Each xlbl In Range("I2:I8")
i = i + 1
.Points(i).DataLabel.Characters.Text = xlbl
Next
End With
With .Axes(xlValue)
.TickLabelPosition = xlNone
.MinimumScale = 50: .MaximumScale = 80: .MajorUnit = 5
.HasTitle = True
With .AxisTitle
.Characters.Text = "体重 身長 Cal"
.AutoScaleFont = False: .Font.Name = "ＭＳ ゴシック": .Font.Size = 10
.Orientation = xlHorizontal
End With
End With
With .Parent
.Width = 500: .Height = 300
End With
With .PlotArea
.Width = 350: .Height = 250: .Top = 50: .Left = 100
End With
With .Axes(xlValue).AxisTitle
.Left = 10: .Top = 10
End With
End With
MsgBox "グラフ作成完了。" & vbLf & vbLf & _
"A8:C13のデータで作った折れ線グラフの数値軸ラベルを無しに" & vbLf & _
"E2:F8のデータで作った散布図のXの値（ラベル）を表示・配置を左に" & vbLf & _
"ラベルの内容はマクロが、E列の値からI列の値に書き換えています。" & vbLf & _
"散布図のマーカーなどは表示無しに。"
End Sub
'------
ご参考程度に。
(HANA)
遅い時間にレスを頂き有り難うございました。
早速試した所、何カ所かエラーで止まった為に("With .SeriesCollection.NewSeries”以降)下記の通り
変更しましたが、HANA様の言われる通り(MsgBox)の動きはしませんでした。変更した箇所は次の通りです。
With ActiveChart
With .SeriesCollection.NewSeries
.ChartType = xlXYScatter
.XValues = "=" & shn & "!R2C5:R8C5"
'.Values = "=" & shn & "!R2C6:R8C6"
'.MarkerBackgroundColorIndex = xlNone
'.MarkerStyle = xlNone
'.ApplyDataLabels ShowCategoryName:=True
'With .DataLabels
' .ShowCategoryName = True
' .ShowValue = False
' .AutoScaleFont = False: .Font.Name = "ＭＳ ゴシック": .Font.Size = 10
' .Position = xlLabelPositionLeft
'End With
End With
With .Axes(xlValue)
.TickLabelPosition = xlNone
.MinimumScale = 50: .MaximumScale = 80: .MajorUnit = 5
.HasTitle = True
With .AxisTitle
.Characters.Text = "体重 身長 Cal"
.AutoScaleFont = False: .Font.Name = "ＭＳ ゴシック": .Font.Size = 10
.Orientation = xlHorizontal
End With
End With
With .Parent
.Width = 500: .Height = 300
End With
With .PlotArea
.Width = 350: .Height = 250: .Top = 50: .Left = 100
End With
With .Axes(xlValue).AxisTitle
.Left = 10: .Top = 10
End With
End With
ActiveChart.SeriesCollection.NewSeries.Values = "=" & shn & "!R2C6:R8C6"
ActiveChart.SeriesCollection.NewSeries.MarkerBackgroundColorIndex = xlNone
ActiveChart.SeriesCollection.NewSeries.MarkerStyle = xlNone
ActiveChart.SeriesCollection.NewSeries.ApplyDataLabels ShowCategoryName:=True
HANA様のVBAやichinose様のVBAを参考に再度検討してみます。。。。（まき）
どこでどんなエラーになって止まったのか教えて下さい。
シートにデータを作る所までは動きましたか？ その後、折れ線グラフも出来ましたか？
(HANA)
済みません。ラベルはマクロで直接変更出来たので 表示形式を変える必要は有りませんでした。
上のコードを直接変更します。 今回は、データ作成マクロとグラフ作成マクロに分けました。 まず、データ作成マクロを実行した後 同じシートで、グラフ作成マクロを実行してみて下さい。
・・・とはいえ、エラーになる原因が分かって対処した訳では無いですが。。。
どこでどの様なエラーに成って止まるのか教えて下さい。
(HANA)
まきです。連絡が遅れてすいませんでした。 ごめんなさい、私はシートのボタンにHANA様のVBAを張って実行させてしまいました。 新規のbookで標準モジュールに入れた所、想像してた物とは違いましたが(プロットエリアとセルの 高さを合わせる)、結果的に行いたいのはY軸の目盛ラベルを3,4軸と合わせるだけなので、HANA様の VBAでも全然OKです。ichinose様のもそうでしたが、やはり標準モジュールに入れて(現在はシートの VBA→Private Sub グラフ_Click()で行っている)行う物でしょうか？それであれば、Sheet1のVBAに >Call mk_graph(データエリア, グラフ範囲, プロット範囲)で 標準モジュールに > Sub mk_graph(ByVal データエリア As Range, ByVal グラフ範囲 As Range, プロット範囲 As Range) と飛ばしてみます。(実は昨日この様にしているのですが。。。但し、上手にいっていませんが)
以上よろしくお願い申し上げます。（まき）
えっと。。。仰って居られることがよく分かりません。
上で載せたコードは、散布図用のデータ範囲や 軸ラベル用のセル範囲等 決まった場所を使っているので直接コード内に書いてありますが 実際はそれぞれ違ってくると思います。
あのようにすれば、３軸っぽく見せられる と言うサンプルコードですから 現在出来ているコードに合うように変えて貰う必要が有ると思います。
(HANA)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.