• ベストアンサー

エクセルの散布図にラベル(系列が2つ)

エクセルの散布図にラベルを付けたいのですが、 いろいろ試しているのですが上手くいきません。(マクロ初心者です。) OKwaveにある質問も見たのですが、同じような状況が見当たらず困っていました。 http://support.microsoft.com/kb/213750 ↑「microsoft サポートオンライン」 のマクロを参考にし、やってみたのですが、系列が1つしかない場合は上手くいくのですが、系列2つでやると 「オブジェクト変数またはwithブロック変数が設定されていません」 というエラーが出てきてしまいます。 どなたかお知恵を貸していただければ幸いです。 ・一つのグラフに系列が2つあり、それぞれいくつかのデータがある。  (例えば、下のデータのB2:C4は系列1「野菜」、   B5:C7は系列2「果物」となっている。) A1:ラベル_____B1:X軸____C1:Y軸 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 この表で 一つの表に2系列をおさめ、 なおかつそれぞれの点に「キャベツ」「イチゴ」などのラベルを表示したいと思っています。 「系列1」の点は「■」「系列2」の点は「●」と分けてあります。 実際にはもっとデータ数が多いため、系列を全て分ける、というのは難しいです。 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
  • ベストアンサー率57% (3570/6232)
回答No.5

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

apfelringo
質問者

お礼

どうもありがとうございました。 無事ラベルを表示することができ、今までラベルがなく とても使いにくかった散布図がとても見やすく、便利になりました。 今回は比較的急ぎで必要だったのですが、 今後もっと勉強をして、皆さんのお手を煩わせないように 努力したいです。 2度にもわたるご回答、どうもありがとうございました。

すると、全ての回答が全文表示されます。

その他の回答 (4)

  • end-u
  • ベストアンサー率79% (496/625)
回答No.4

#1のxls88さんのレスで既に答えが出ていますので余計な事だったらゴメンなさい。 要は、『グラフを選択してから実行してください』ってことです。 >系列が1つしかない場合は上手くいくのですが、系列2つでやると >「オブジェクト変数またはwithブロック変数が設定されていません」 >というエラーが出てきてしまいます。 系列が1つの時はグラフを選択して実行したのに対し、 系列が2つの時にグラフを選択して実行しなかったから『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軸アドレスの1コ左のセル範囲をLoop     For Each r In Range(v(1)).Offset(, -1)       i = i + 1       sr.Points(i).DataLabel.Text = r.Value     Next   Next End Sub

apfelringo
質問者

お礼

ごめんなさい。 私も補足を書いた後に、グラフを選択していなかったことに 気がつきました・・・。 初心者に丁寧にご指導ありがとうございました。

すると、全ての回答が全文表示されます。
  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.3

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

この投稿のマルチメディアは削除されているためご覧いただけません。
apfelringo
質問者

お礼

細かなご指摘ありがとうございます。 説明については、自分なりに気をつけていたつもりなのですが、 分かりにくかったのなら申し訳ありません。 無事に解決いたしました。 どうもありがとうございました。

すると、全ての回答が全文表示されます。
  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.2

こんにちは。 >「オブジェクト変数または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

apfelringo
質問者

補足

ありがとうございます。 何せ初心者なもので、どこをどう直せばいいかも分からず苦戦しています。 早速教えていただいたスクリプトでやってみたのですが、 (No.1さんにつけた補足にもあるのですが) ラベルは表示されたのですが、 イチゴやミカンなどのポイントにも野菜の名前が入ってしまいます。 イチゴのラベルが入るところに「キャベツ」 ミカンのラベルが入るところに「トマト」 リンゴのところに「キュウリ」とあります。 (キャベツやトマト等、系列1のラベルが付いたポイントが2つずつある。) 系列2の点もA2:A4の文字列を取ってきてしまっているみたいです。 これさえ何とかなるといいんですが・・・ 時間がありましたらまた知恵をお貸し下さい。 本当にありがとうございます。

すると、全ての回答が全文表示されます。
  • xls88
  • ベストアンサー率56% (669/1189)
回答No.1

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

apfelringo
質問者

お礼

無事に解決しました。 どうもありがとうございました。 グラフの選択を忘れていたため上手くいかなかったようです。 どうもご迷惑をおかけしました。 すばやいご解答、ありがとうございました。

apfelringo
質問者

補足

ありがとうございます。 ただ、やってみたところやはりエラーになってしまいました。 「オブジェクト変数またはwithブロック変数が設定されていません」 というエラーで、デバッグでは For i = 1 To ActiveChart.SeriesCollection.Count の部分が黄色く反転されます。 セキュリティソフトとの関係で↑のエラーが出ることがあるということを聞いたのですが、全くラベルが表示されないわけではないので、それが原因ではなさそうです。 http://d.hatena.ne.jp/shogo4405/20081213/1229162489 ↑このサイトにあったスクリプトをそのまま使ったところ、 とりあえずラベルは表示されたのですが、 もともとのデータの形式が違ったため、 A1:ラベル_____B1:X軸____C1:Y軸 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 イチゴやミカンなどのポイントにも野菜の名前が入ってしまいます。 (キャベツやトマト等、系列1のラベルが付いたポイントが2つある。) ちなみにそれは Public Sub 散布図にラベルを追加する() AttachLabelsToPoint End Sub Private Function AttachLabelsToPoint(Optional labels As range = Nothing) Dim i As Integer, j As Integer If (ActiveChart Is Nothing) Then MsgBox ("アクティブなグラフはありません。" & Chr(10) & Chr(13) & "ラベルを追加するグラフを選んでください。") Exit Function End If ' ラベル開始セルの指定 If (labels Is Nothing) Then On Error Resume Next Set labels = Application.InputBox(Prompt:="ラベル開始セル名を入力してください。例)A1", Type:=8) If (Err.Number <> 0) Then Exit Function End If On Error GoTo 0 End If ' スクリーンの更新をOFF Application.ScreenUpdating = False ' ラベルの記入処理 For i = 1 To ActiveChart.SeriesCollection.Count For j = 1 To ActiveChart.SeriesCollection(i).points.Count ActiveChart.SeriesCollection(i).points(j).HasDataLabel = True ActiveChart.SeriesCollection(i).points(j).DataLabel.Text = labels.Offset(j - 1, 0).Value Next j Next i End Function こんなスクリプトでした。 非常に厚かましいお願いですが、お時間がありましたら またよろしくお願いします。

すると、全ての回答が全文表示されます。

関連するQ&A