任意にデータの範囲を選択し、グラフを描画したい

質問

質問を閲覧していただきありがとうございます。
できればみなさんのお力を貸していただきたいことがあり、質問しました。
以下にマクロ作成に用いたプログラムの仕様とコードを貼りますので、ご指摘等いただけましたら幸いです。

まず、今回のマクロの目的は
・既に存在するエクセルデータから、x軸、y軸のデータ列の長さに応じたグラフを描画するVBプログラムを書く事　です。
・可能ならば、既存のふたつのグラフを結合したものを新しく表示する
※データシートの画像は添付しましたのでご覧ください。

以上のふたつとなります。

理想形としては、
A2 ~ A1025までをｘ軸のデータ、B2~B1025までの実データ値としたグラフAを一つ
D2 ~ E1025までをｘ軸のデータ、E2~E1025までの実データ値としたグラフBを一つ
上記二つのグラフを結合したグラフを一つ

の３つのグラフが自動的に作成され、エクセルファイル上に表示されている　といったような感じです。

私の書いたコードの問題点としては、

・グラフAグラフBともに「ｘ軸と実データが正しく対応していない」
→本来両方のグラフにおいてはグラフの右端まで折れ線グラフが続いているはずですが、ｘ軸の値にして約１０００の所でデータが終わってしまっています。

・グラフBでは、D2 ~ D344, E2 ~ E344　を基にしたグラフ一つのみが描画されているはずですが、ここには何故か二つ以上の折れ線グラフがあるようにみえ、グラフB右には系列１～５までがあるように書かれています。（理想としては５個ではなく実データを示すもの一つのみ）

・ふたつのグラフの結合方法が不明

という感じです。

以下にプログラムを貼ります。
お時間ありましたら、ご指摘の程宜しくお願い致します。

～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
Sub グラフ描画()

chart_title1 = "グラフA"
chart_title2 = "グラフB"

'軸のタイトル
x_title = "周波数[Hz]"
y_title = "パワー"

' -------------------------グラフ作成----------------------

' グラフを描画

Dim chartObj1 As ChartObject
Set chartObj1 = ActiveSheet.ChartObjects.Add(1, 1, 300, 200)

With chartObj1.Chart

' データ範囲をセット
.SetSourceData Source:=Range(Range("B2"), _
Cells(2, 1).End(xlDown))

' x軸の項目軸範囲をセット
.SeriesCollection(1).XValues = Range(Range("A2"), _
Cells(1, 1).End(xlDown))

' オプションをセット
.ChartType = xlXYScatterSmoothNoMarkers ' 散布図
.HasTitle = True
.ChartTitle.Characters.Text = chart_title
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = x_title
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = y_title

' x軸の最大値、最小値設定
.Axes(xlCategory, xlPrimary).MinimumScale = 0
.Axes(xlCategory, xlPrimary).MaximumScale = 4500

' y軸の最大値、最小値設定
.Axes(xlValue).MinimumScale = -10
.Axes(xlValue).MaximumScale = 3

End With

Dim chartObj2 As ChartObject
Set chartObj2 = ActiveSheet.ChartObjects.Add(1, 320, 300, 200)
With chartObj2.Chart

' データ範囲をセット
.SetSourceData Source:=Range(Range("E2"), _
Cells(2, 1).End(xlDown))

' x軸の項目軸範囲をセット
.SeriesCollection(1).XValues = Range(Range("D2"), _
Cells(1, 1).End(xlDown))

' オプションをセット
.ChartType = xlXYScatterSmoothNoMarkers ' 散布図
.HasTitle = True
.ChartTitle.Characters.Text = chart_title
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = x_title
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = y_title

' x軸の最大値、最小値設定
.Axes(xlCategory, xlPrimary).MinimumScale = 0
.Axes(xlCategory, xlPrimary).MaximumScale = 4500

' y軸の最大値、最小値設定
.Axes(xlValue).MinimumScale = -10
.Axes(xlValue).MaximumScale = 3

End With

End Sub

～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～

回答No.2

mitarashi

#1です。
A,B列と、C,D列のデータ数が異なる場合は、それぞれ別個に取得してやれば良いです。
少しはスッキリさせたいと、他のところも多少いじってあります。ご参考まで。
Sub グラフ描画()
Dim chart_title1 As String, chart_title2 As String
Dim x_title As String, y_title As String
Dim chartObj1 As ChartObject
Dim chartObj2 As ChartObject
Dim dataRange1 As Range, dataRange2 As Range
Dim strFormula As String
Dim mySheet As Worksheet
Dim seriesA1 As Series, seriesA2 As Series, seriesB As Series
Const seriesFormula = "=SERIES(myColTytle,myXValues,myValues,myNo)"

chart_title1 = "グラフA"
chart_title2 = "グラフB"
'軸のタイトル
x_title = "周波数[Hz]"
y_title = "パワー"

' -------------------------グラフ作成----------------------
' グラフを描画
Set mySheet = ActiveSheet
Set chartObj1 = mySheet.ChartObjects.Add(200, 1, 200, 300)
With mySheet
Set dataRange1 = .Range(.Range("A2"), .Range("A" & .Rows.Count).End(xlUp)).Resize(, 2)
Set dataRange2 = .Range(.Range("C2"), .Range("C" & .Rows.Count).End(xlUp)).Resize(, 2)
End With
With chartObj1.Chart
Set seriesA1 = .SeriesCollection.NewSeries
seriesA1.XValues = dataRange1.Columns(1)
seriesA1.Values = dataRange1.Columns(2)
Set seriesA2 = .SeriesCollection.NewSeries
seriesA2.XValues = dataRange2.Columns(1)
seriesA2.Values = dataRange2.Columns(2)

' オプションをセット
.ChartType = xlXYScatterSmoothNoMarkers ' 散布図
.SetElement msoElementLegendTop
.HasTitle = True
.ChartTitle.Characters.Text = chart_title1
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = x_title
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = y_title
End With

Set chartObj2 = mySheet.ChartObjects.Add(420, 1, 200, 300)
With chartObj2.Chart
.ChartType = xlXYScatterSmoothNoMarkers ' 散布図
Set seriesB = .SeriesCollection.NewSeries
strFormula = seriesFormula
strFormula = Replace(strFormula, "myColTytle", "")
strFormula = Replace(strFormula, "myXValues", _
"(" & mySheet.Name & "!" & dataRange1.Columns(1).Address & "," & mySheet.Name & "!" & dataRange2.Columns(1).Address & ")")
strFormula = Replace(strFormula, "myValues", _
"(" & mySheet.Name & "!" & dataRange1.Columns(2).Address & "," & mySheet.Name & "!" & dataRange2.Columns(2).Address & ")")
strFormula = Replace(strFormula, "myNo", "1")
seriesB.Formula = strFormula

' オプションをセット
.HasTitle = True
.SetElement msoElementLegendTop
.ChartTitle.Characters.Text = chart_title2
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = x_title
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = y_title
End With
End Sub

回答No.1

mitarashi

無理矢理ですが、下記の様なコードでいかがでしょうか。
データを統合するのに、XValues, Valuesを指定する方法は分かりませんでしたので（UnionではNG）、Formulaを指定しています。適当な試験データを使ったので、軸の最大値、最小値指定は削りました。Replaceを使っているのは文字列の合成がやたらと長くなるのを防止するためですが、十分長いですね(^^;)
グラフBのseries formulaは、「=SERIES(,(Sheet1!$A$2:$A$1025,Sheet1!$C$2:$C$1025),(Sheet1!$B$2:$B$1025,Sheet1!$D$2:$D$1025),1)」となっています。

Sub グラフ描画()
Dim chart_title1 As String, chart_title2 As String
Dim x_title As String, y_title As String
Dim chartObj1 As ChartObject
Dim chartObj2 As ChartObject
Dim targetRange As Range
Dim strFormula As String
Const seriesFormula = "=SERIES(myColTytle,myXValues,myValues,myNo)"

chart_title1 = "グラフA"
chart_title2 = "グラフB"
'軸のタイトル
x_title = "周波数[Hz]"
y_title = "パワー"

' -------------------------グラフ作成----------------------
' グラフを描画

Set chartObj1 = ActiveSheet.ChartObjects.Add(200, 1, 200, 300)
With ActiveSheet
Set targetRange = .Range(.Range("A2"), .Range("A" & .Rows.Count).End(xlUp)).Resize(, 4)
End With
With chartObj1.Chart
.SeriesCollection.NewSeries
'本来は下記で十分　第二段階への伏線でテスト
'.SeriesCollection(1).XValues = targetRange.Columns(1)
'.SeriesCollection(1).Values = targetRange.Columns(2)
strFormula = seriesFormula
strFormula = Replace(strFormula, "myColTytle", "")
strFormula = Replace(strFormula, "myXValues", ActiveSheet.Name & "!" & targetRange.Columns(1).Address)
strFormula = Replace(strFormula, "myValues", ActiveSheet.Name & "!" & targetRange.Columns(2).Address)
strFormula = Replace(strFormula, "myNo", "1")
.SeriesCollection(1).Formula = strFormula
.SeriesCollection.NewSeries
'.SeriesCollection(2).XValues = targetRange.Columns(3)
'.SeriesCollection(2).Values = targetRange.Columns(4)
strFormula = seriesFormula
strFormula = Replace(strFormula, "myColTytle", "")
strFormula = Replace(strFormula, "myXValues", ActiveSheet.Name & "!" & targetRange.Columns(3).Address)
strFormula = Replace(strFormula, "myValues", ActiveSheet.Name & "!" & targetRange.Columns(4).Address)
strFormula = Replace(strFormula, "myNo", "2")
.SeriesCollection(2).Formula = strFormula

' オプションをセット
.ChartType = xlXYScatterSmoothNoMarkers ' 散布図
.SetElement msoElementLegendTop
.HasTitle = True
.ChartTitle.Characters.Text = chart_title1
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = x_title
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = y_title

End With

Set chartObj2 = ActiveSheet.ChartObjects.Add(420, 1, 200, 300)
With chartObj2.Chart
.ChartType = xlXYScatterSmoothNoMarkers ' 散布図
.SeriesCollection.NewSeries
strFormula = seriesFormula
strFormula = Replace(strFormula, "myColTytle", "")
strFormula = Replace(strFormula, "myXValues", _
"(" & ActiveSheet.Name & "!" & targetRange.Columns(1).Address & "," & ActiveSheet.Name & "!" & targetRange.Columns(3).Address & ")")
strFormula = Replace(strFormula, "myValues", _
"(" & ActiveSheet.Name & "!" & targetRange.Columns(2).Address & "," & ActiveSheet.Name & "!" & targetRange.Columns(4).Address & ")")
strFormula = Replace(strFormula, "myNo", "1")
.SeriesCollection(1).Formula = strFormula

' オプションをセット
.HasTitle = True
.SetElement msoElementLegendTop
.ChartTitle.Characters.Text = chart_title2
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = x_title
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = y_title
End With
End Sub

参考URL：

http://okwave.jp/qa/q8310732.html

お礼

早速の返信ありがとうございます！

私が提示していた問題点についてなのですが、
データがｘ軸に正しく対応してない問題は解消できました！

ただ、もし宜しければ一つお聞きしたいことがあります。
今回の二つのグラフを一つの図に書く場合、
「二つのグラフの要素数が等しい場合」には問題なく動いたのですが
「二つのグラフの要素数が異なる場合」にはグラフの描画を行うことができませんでした。

この、「二つのグラフの要素数が異なる場合」にも、
一つの図に二つのグラフを書く為にはどの様にすればいいのでしょうか？

私の説明不足もあり再度の質問となってしまし申し訳ありません。
もしお時間ありましたらご回答いただければと思います。

以上
回答ありがとうございました