エクセルの散布図にラベル（系列が２つ）

質問

エクセルの散布図にラベルを付けたいのですが、
いろいろ試しているのですが上手くいきません。（マクロ初心者です。）
OKwaveにある質問も見たのですが、同じような状況が見当たらず困っていました。
http://support.microsoft.com/kb/213750
↑「microsoft サポートオンライン」
のマクロを参考にし、やってみたのですが、系列が1つしかない場合は上手くいくのですが、系列２つでやると
「オブジェクト変数またはwithブロック変数が設定されていません」
というエラーが出てきてしまいます。

どなたかお知恵を貸していただければ幸いです。

・一つのグラフに系列が２つあり、それぞれいくつかのデータがある。
　（例えば、下のデータのB2:C4は系列１「野菜」、
　　B5:C7は系列２「果物」となっている。）

A1:ラベル_____B1:Ｘ軸____C1:Ｙ軸
A2:キャベツ___B2:12______C2:5
A3:トマト_____B3:9_______C3:7
A4:キュウリ___B4:5_______C4:3
A5:イチゴ_____B5:4_______C5:8
A6:ミカン_____B6:1_______C6:4
A7:リンゴ_____B7:1_______C7:4

この表で
一つの表に２系列をおさめ、
なおかつそれぞれの点に「キャベツ」「イチゴ」などのラベルを表示したいと思っています。
「系列１」の点は「■」「系列２」の点は「●」と分けてあります。
実際にはもっとデータ数が多いため、系列を全て分ける、というのは難しいです。

VBAを使って出来るやり方がありましたら是非教えて下さい。

なお、サポートオンラインからコピーして使った
マクロは以下のとおりです。

Sub AttachLabelsToPoints()

'Dimension variables.
Dim Counter As Integer, ChartName As String, xVals As String

' Disable screen updating while the subroutine is run.
Application.ScreenUpdating = False

'Store the formula for the first series in "xVals".
xVals = ActiveChart.SeriesCollection(1).Formula

'Extract the range for the data from xVals.
xVals = Mid(xVals, InStr(InStr(xVals, ","), xVals, _
Mid(Left(xVals, InStr(xVals, "!") - 1), 9)))
xVals = Left(xVals, InStr(InStr(xVals, "!"), xVals, ",") - 1)
Do While Left(xVals, 1) = ","
xVals = Mid(xVals, 2)
Loop

'Attach a label to each data point in the chart.
For Counter = 1 To Range(xVals).Cells.Count
ActiveChart.SeriesCollection(1).Points(Counter).HasDataLabel = _
True
ActiveChart.SeriesCollection(1).Points(Counter).DataLabel.Text = _
Range(xVals).Cells(Counter, 1).Offset(0, -1).Value
Next Counter

End Sub

どうぞよろしくお願いします。

回答No.5

Wendy02 · ベストアンサー

訂正します。

2系列の意味を間違えて取っていました。
これでどうでしょう。

ただ、現状では、同じ値のところは、ラベルがダブリます。
それを修正するためには、一旦、データを確保しなければならないように考えていますが、手間が多そうな気がします。

'-------------------------------------------

Sub AttachLabelsToPoints_J1()
　　'2系列以上にデータラベルを入れる
　　'変数の定義
　　Dim i As Long 'Longに替える
　　Dim j As Long
　　Dim ChartName As String
　　Dim xVals As String
　　Dim buf As String
　　Dim myChart As ChartObject

　　'プロシージャの実行中の画面を停止させる
　　'Application.ScreenUpdating = False

　　'オブジェクトがない場合は、マクロ中止
　　If ActiveSheet.ChartObjects.Count = 0 Then Exit Sub
　　Set myChart = ActiveSheet.ChartObjects(1)

　　With myChart
　　　 For j = 1 To .Chart.SeriesCollection.Count
　　　　'xVal に最初の数式をストックする
　　　　xVals = .Chart.SeriesCollection(j).Formula

　　　　'xVal から、範囲からデータを抜き出す
　　　　buf = Mid$(xVals, InStr(1, xVals, ",") + 1)
　　　　xVals = Left(buf, InStr(1, buf, ",") - 1)

　　　　'グラフに、それぞれのデータポイントにラベルをつける

　　　　　　For i = 1 To Range(xVals).Cells.Count
　　　　　　　　.Chart.SeriesCollection(j).Points(i).HasDataLabel = _
　　　　　　　　True
　　　　　　　　.Chart.SeriesCollection(j).Points(i).DataLabel.Text = _
　　　　　　　　Range(xVals).Offset(, -1).Cells(i, 1).Value

　　　　　　Next i
　　　　　　'フォントサイズ変更
　　　　　　.Chart.SeriesCollection(j).DataLabels.AutoScaleFont = False
　　　　　　.Chart.SeriesCollection(j).DataLabels.Font.Size = 9
　　　　Next j
　　End With
End Sub

お礼

どうもありがとうございました。
無事ラベルを表示することができ、今までラベルがなく
とても使いにくかった散布図がとても見やすく、便利になりました。

今回は比較的急ぎで必要だったのですが、
今後もっと勉強をして、皆さんのお手を煩わせないように
努力したいです。

2度にもわたるご回答、どうもありがとうございました。