棒グラフのデータラベルの位置

質問

Excel2007で作成した棒グラフのデータラベルの位置なのですが、同じくらいのパーセンテージが並ぶと重なってしまって全く見えません。手作業でいつも補正しているのですが、VBAなどプログラムを使うことで簡単に補正できるようになるものでしょうか。できるのであれば技術者の派遣をお願いするなどして対応したいと思っているのですが、VBAでそもそもどこまでできるのかも分からないため、お分かりになる方ご教示いただけますと助かります。
よろしくお願いいたします。

回答No.2

imogasi · ベストアンサー

どういうロジック（ルール）で、どうずらすか、個別でなく、ルールを作れるなら、それを考えないとダメでしょう。
それは技術者だから優れたアイデアが出るとは限らないように思う。
又どんな場合にも通用するルールというのも考えにくいように思いますですが。
そのアイデアを文章表現して、（別）質問すれば、簡単なルールなら、あるいはＶＢＡで実現（回答）してくれるかも知れません。
（１）ラベル文字方向に角度を付ける
（２）上下位置を互い違いにする(原初位置より、一定数だけプラスとマイナスを繰返す）
などのようなことです。
後者は
Sub Macro4()
For i = 1 To ActiveChart.SeriesCollection(1).Points.Count
ActiveChart.SeriesCollection(1).Points(i).DataLabel.Select
If i Mod 2 = 0 Then '偶数番、奇数番目で表示位置上下に差をつける
Selection.Top = Selection.Top + 10
Else
Selection.Top = Selection.Top - 10
End If
Next i
End Sub
上記は私の思いつきで、データの有様によっては、見やすくなるとは限らないことも判るのですが。

お礼

お礼が遅くなり申し訳ございません。
上記ご連絡いただいたロジックでヒントを得ました。
業者に相談し、進捗している状況です。大変ありがとうございました。

回答No.3

xls88

下記コードを試してください。
対象グラフを選択して置いて実行してください。
系列数が1つの場合です。
系列が複数ある場合はもう少し考えなければいけません。

データラベルはWidth,Heightが取れません。
重なり量の計算にFont.Sizeを代用しています。
移動量はラベルの余白を考慮して補正値を0.7で入れてあります。

Dim fsize As Variant
Dim dlbtop1 As Variant
Dim dlbtop2 As Variant
Dim i As Long

With ActiveChart.SeriesCollection(1)
'ラベル初期化
.DataLabels.Delete
.HasDataLabels = True
Application.ScreenUpdating = True

fsize = .DataLabels.Font.Size
For i = 1 To .Points.Count - 1
dlbtop1 = .Points(i).DataLabel.Top
dlbtop2 = .Points(i + 1).DataLabel.Top
If Abs(dlbtop1 - dlbtop2) < fsize Then
With .Points(i + 1).DataLabel
If dlbtop1 < dlbtop2 Then
.Top = .Top + (fsize - (dlbtop2 - dlbtop1)) * 0.7
Else
.Top = .Top - (fsize - (dlbtop1 - dlbtop2)) * 0.7
End If
End With
'ラベル移動完了までの時間稼ぎ
Application.Wait Now + TimeValue("00:00:01")
End If
Next
End With

お礼

お礼が遅くなり申し訳ございません。
上記大変ありがとうございました。ロジックを考えていけば実現できることが分かりました。
大変ありがとうございました。

回答No.1

某HN クロメート(Chromate)（@CoalTar）

たぶん、重なった時の処理方法を明確にできれば、対応できると思います
以下は、処理できるか否か程度の試験的マクロ(使い物にならない)
Sub Macro1()
Dim n As Byte
　　 'ActiveSheet.ChartObjects("グラフ 3").Activate
With ActiveChart.SeriesCollection(1)
For n = 1 To 9
　　 '下記の内容を検討する必要がある
　　 If Abs(.Points(n).DataLabel.Top - .Points(n + 1).DataLabel.Top) < 20 Then
　　 .Points(n + 1).DataLabel.Top = .Points(n + 1).DataLabel.Top - 10
　　 End If
Next n
End With
End Sub
結果は添付図

お礼

お礼が遅くなりました。マクロで動かすことができることが分かり大変助かりました。
大変ありがとうございました。