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

Question

エクセルの散布図にラベルを付けたいのですが、
いろいろ試しているのですが上手くいきません。（マクロ初心者です。）
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

どうぞよろしくお願いします。

Wendy02 · Accepted Answer

訂正します。

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

end-u · Answer

＃1のxls88さんのレスで既に答えが出ていますので余計な事だったらゴメンなさい。
要は、『グラフを選択してから実行してください』ってことです。

>系列が1つしかない場合は上手くいくのですが、系列２つでやると
>「オブジェクト変数またはwithブロック変数が設定されていません」
>というエラーが出てきてしまいます。
系列が１つの時はグラフを選択して実行したのに対し、
系列が２つの時にグラフを選択して実行しなかったから『ActiveChartがない』というエラーです。

Sub test()
　　Dim sr As Series '系列Loop用
　　Dim r　As Range　'ラベルのセル範囲Loop用
　　Dim i　As Long
　　Dim v

　　If ActiveChart Is Nothing Then
　　　　MsgBox "グラフを選択して実行"
　　　　Exit Sub
　　End If
　　'それぞれの系列ごとにLoop
　　For Each sr In ActiveChart.SeriesCollection
　　　　'データラベルの表示
　　　　sr.ApplyDataLabels AutoText:=True
　　　　'系列のFormula文字列、"=SERIES(,x,y,)"を『,』で分割
　　　　v = Split(sr.Formula, ",")
　　　　i = 0
　　　　'分割して得たx軸アドレスの１コ左のセル範囲をLoop
　　　　For Each r In Range(v(1)).Offset(, -1)
　　　　　　i = i + 1
　　　　　　sr.Points(i).DataLabel.Text = r.Value
　　　　Next
　　Next
End Sub

Wendy02 · Answer

こんにちは。

最初に、細かいことを言うようですが、一応、VBA プログラマは、コードは「スクリプト」とは呼びません。コードと呼びます。スクリプトは、スクリプト言語のプログラミング・コードのことを指します。

また、持ち込むコードはひとつきりにしてください。出来れば、ご自身のコードにしてください。他人のコードをあれこれと出されたら、ご自身で勉強してください、と言うしかなくなります。

他人のコードを直すほどまでの余裕は持ちません。リンク先のコードは、形にこだわりすぎて、あまりうまくありません。ActiveChart は、Chart をActiveにしなければなりませんから、プログラムが甘くなってしまいます。VBAであっても、オブジェクトぐらいは関数プロシージャの引数にして、引数の前に、チェックしなければなりません。

>系列２の点もA2:A4の文字列を取ってきてしまっているみたいです

そのように作っていますから、当然、そのように出ます。

>（キャベツやトマト等、系列１のラベルが付いたポイントが２つずつある。）

それは、どういう内容ですか？ワンセルに、二種類入っているということでしょうか。

　　--->キャベツ,トマト

A列のセルには通常ひとつの項目だと思います。しかし、ひとつの項目でないとしたら、プログラムとしては可能でも、そういう前提は、最初から説明していただかないと、とてもわかるものではありません。Microsoft のサポートにも、どこにも書かれているわけではありません。

Wendy02 · Answer

こんにちは。

>「オブジェクト変数またはwithブロック変数が設定されていません」
ActiveChart つまり、Chart をアクティブにしていないといけないのですが、変数の宣言もヘンですね。中途ということよりも、雑なのかなって思います。

''Dim ChartName As String '←このマクロでは不要
'Application.ScreenUpdating = False　'←コメントブロックしました。このマクロでは、必要があまりありません。

コメントは日本語に換え、多少、こちらでアレンジしました。
シートに貼り付けたグラフですと、以下のようになります。
注意：時々、散布図は、Excel のバージョンによって稼動しないことがありましたが、これに関しては下位バージョンでも稼動を確認しました。
'-------------------------------------------
Sub AttachLabelsToPoints_J()
　　'2系列以上にデータラベルを入れる
　　'http://support.microsoft.com/kb/213750
　　'変数の定義
　　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
　　　　'xVal に最初の数式をストックする
　　　　xVals = .Chart.SeriesCollection(1).Formula
　　　　
　　　　'xVal から、範囲からデータを抜き出す
　　　　buf = Mid$(xVals, InStr(1, xVals, ",") + 1)
　　　　xVals = Left(buf, InStr(1, buf, ",") - 1)
　　　　
　　　　'グラフに、それぞれのデータポイントにラベルをつける
　　　 For j = 1 To .Chart.SeriesCollection.Count
　　　　For i = 1 To Range(xVals).Cells.Count
　　　　　　.Chart.SeriesCollection(j).Points(i).HasDataLabel = _
　　　　　　True
　　　　　　.Chart.SeriesCollection(j).Points(i).DataLabel.Text = _
　　　　　　Range(xVals).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

xls88 · Answer

For文で系列の数だけループしてみました。

Sub AttachLabelsToPoints()
    'Dimension variables.
    Dim Counter As Integer, ChartName As String, xVals As String
    Dim i As Integer

    ' Disable screen updating while the subroutine is run.
    Application.ScreenUpdating = False

    For i = 1 To ActiveChart.SeriesCollection.Count
        'Store the formula for the first series in "xVals".
        xVals = ActiveChart.SeriesCollection(i).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(i).Points(Counter).HasDataLabel = True
            ActiveChart.SeriesCollection(i).Points(Counter).DataLabel.Text = _
                Range(xVals).Cells(Counter, 1).Offset(0, -1).Value
        Next Counter
    Next i
End Sub

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

訂正します。

＃1のxls88さんのレスで既に答えが出ていますので余計な事だったらゴメンなさい。

こんにちは。

こんにちは。

この回答への補足

For文で系列の数だけループしてみました。

この回答への補足

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング