エクセルで円グラフ作成時のデータラベル

質問

エクセル2000です。
マクロで何十種類かのデータをもとにその数だけ円グラフを作成し、プリントしようとおもっています。
グラフの項目はすべて同じで、数値のみ変わるので、最初に雛形のグラフをつくり、データ欄のみマクロで書き換えてプリントしようと思いました。
ところが、項目ごとの数値の割合によってデータラベルが重なってしまい、添付のサンプルのようにとても見にくいものが出来てしまいました。
グラフなんてあまりつくったことがないのですが、データラベルが重ならないような設定はあるのでしょうか？

回答No.6

end-u · ベストアンサー

Sub Test　　　　　　スタート（ChartObjectのLoopとチェック）
Sub TestSub1　　　　DataLabelを一旦外側へバランスよく配置する
Sub TestSub2　　　　DataLabelをLoopして重ならないように再配置する
Function TestFunc1　DataLabelの重なり判定
Function TestFunc2　重なり解消の遷移（逆Loop）
Function TestFunc3　重なり解消の遷移（順Loop）

６個のプロシージャに分けて書いてます。
ChartがActiveになっているとなんか遅いので
Chartを選択していたら実行しないようにしてます。

最初の部分でDataLabelの大きさを固定しています。
>Const LBW = 90　　　'DataLabel.Width固定
>Const LBH = 36　　　'DataLabel.Height固定
フォントサイズが大きく変わるようだったら、
この値を変えないといけません。
コード内でフォントサイズから変動させるようにしてもいいかもしれませんが。
それにText文字数が多い場合も折り返し行数が変わりますから
LBHを変えるか、Text文字を変えるかしたほうが良いと思います。

いずれにしても、Chartの状態によってはうまくいかないケースもあります。
コードもあまり整理してないので怪しいところが多々あります。
習作レベルとして、参考程度に。

お礼

end-uさま、いつもありがとうございます。
こんなに手の込んだコードをわざわざ書いていただき、感謝感激です。
内容の解読はまだ手付かずですが、何度かためしたところデータラベルに枠線があるとどうしても重なることが多いです。
.DataLabels.Border.LineStyle = xlNoneにしたところ、まだ少ないデータでのテストですが重なりがなくなりました。

ほんとにありがとうございます。

補足

十分実用に耐えることがわかりました。
本当にありがとうございました。

回答No.5

end-u

'（続き）
'---------
'重なり判定
Function TestFunc1(ByRef d1 As DataLabel, _
　　　　　　　　　 ByRef d2 As DataLabel) As Boolean
　TestFunc1 = (Abs(d1.Left - d2.Left) < LBW) _
　　　　　And (Abs(d1.Top - d2.Top) < LBH)
End Function
'---------
'重なり解消の遷移（逆Loop）
Function TestFunc2(ByRef d1 As DataLabel, _
　　　　　　　　　 ByRef d2 As DataLabel) As Boolean
　Dim flg As Boolean

　Select Case CHK
　Case 1 '左方向へ
　　If d1.Left - LBW > MN Then
　　　d2.Left = d1.Left - LBW
　　　If d2.Left > MXX Then d2.Left = MN
　　　If d2.Top > MXY Then d2.Top = MN
　　　flg = True
　　Else
　　　CHK = 2
　　End If
　Case 2 '下方向へ
　　If d1.Top + LBH * 2 < MXY Then
　　　d2.Top = d1.Top + LBH
　　　d2.Left = MN
　　　If d2.Left > MXX Then d2.Left = MN
　　　flg = True
　　Else
　　　CHK = 3
　　End If
　Case 3 '右方向へ
　　If d1.Left + LBW * 2 < MXX Then
　　　d2.Left = d1.Left + LBW
　　　flg = True
　　Else
　　　CHK = 4
　　End If
　Case 4 '上方向へ
　　If d1.Top - LBH > MN Then
　　　d2.Top = d1.Top - LBH
　　　d2.Left = MXX - LBW - MN
　　　If d2.Top > MXY Then d2.Top = MN
　　　flg = True
　　Else
　　　'解なし。Exit Do
　　　CHK = 0
　　End If
　End Select
　TestFunc2 = flg
End Function
'---------
'重なり解消の遷移（順Loop）
Function TestFunc3(ByRef d1 As DataLabel, _
　　　　　　　　　 ByRef d2 As DataLabel) As Boolean
　Dim flg As Boolean

　Select Case CHK
　Case 1 '右
　　If d1.Left + LBW * 2 < MXX Then
　　　d2.Left = d1.Left + LBW
　　　If d2.Top > MXY Then d2.Top = MN
　　　flg = True
　　Else
　　　CHK = 2
　　End If
　Case 2 '下
　　If d1.Top + LBH * 2 < MXY Then
　　　d2.Top = d1.Top + LBH
　　　d2.Left = MXX - LBW - MN
　　　flg = True
　　Else
　　　CHK = 3
　　End If
　Case 3 '左
　　If d1.Left - LBW > MN Then
　　　d2.Left = d1.Left - LBW
　　　If d2.Left > MXX Then d2.Left = MN
　　　flg = True
　　Else
　　　CHK = 4
　　End If
　Case 4 '上
　　If d1.Top - LBH > MN Then
　　　d2.Top = d1.Top - LBH
　　　d2.Left = MN
　　　If d2.Top > MXY Then d2.Top = MN
　　　If d2.Left > MXX Then d2.Left = MN
　　　flg = True
　　Else
　　　CHK = 0
　　End If
　End Select
　TestFunc3 = flg
End Function
'---------
'（終わり）

回答No.4

end-u

'（続き）
Sub TestSub2(ByRef dL As DataLabels)
　Dim i　 As Long
　Dim j　 As Long
　Dim p　 As Long
　Dim flg As Boolean
　Dim f() As Boolean

　With dL
　　'DataLabels.Item(.Count)の重なり判定と処理
　　If TestFunc1(.Item(1), .Item(.Count)) Then
　　　.Item(.Count).Left = .Item(1).Left - LBW
　　End If
　　'DataLabelsを逆Loop
　　For i = .Count To 2 Step -1
　　　'遷移方向の初期値設定
　　　With .Item(i)
　　　　If .Left < MXX \ 2 Then
　　　　　If .Top < MXY \ 2 Then
　　　　　　CHK = 1
　　　　　Else
　　　　　　CHK = 2
　　　　　End If
　　　　Else
　　　　　If .Top < MXY \ 2 Then
　　　　　　CHK = 4
　　　　　Else
　　　　　　CHK = 3
　　　　　End If
　　　　End If
　　　End With
　　　'重なり判定をf()に記憶
　　　ReDim f(1 To i - 1)
　　　For j = i - 1 To 1 Step -1
　　　　f(j) = TestFunc1(.Item(i), .Item(j))
　　　　If Not f(j) Then Exit For
　　　Next
　　　'遷移処理のためのLoop
　　　For j = i - 1 To 2 Step -1
　　　　If Not f(j) Then Exit For
　　　　If CHK = 0 Then Exit For
　　　　flg = False
　　　　Do Until flg Or CHK = 0
　　　　　flg = TestFunc2(.Item(i), .Item(j))
　　　　Loop
　　　Next
　　Next
　　'念の為、前半を順Loop
　　CHK = 1
　　p = .Count \ 2
　　For i = 1 To p - 1
　　　ReDim f(i + 1 To p)
　　　For j = i + 1 To p
　　　　f(j) = TestFunc1(.Item(i), .Item(j))
　　　　If Not f(j) Then Exit For
　　　Next
　　　For j = i + 1 To p - 1
　　　　If Not f(j) Then Exit For
　　　　If CHK = 0 Then Exit For
　　　　flg = False
　　　　Do Until flg Or CHK = 0
　　　　　flg = TestFunc3(.Item(i), .Item(j))
　　　　Loop
　　　Next
　　　With .Item(i + 1)
　　　　If .Left < MXX \ 2 Then
　　　　　If .Top < MXY \ 2 Then
　　　　　　CHK = 4
　　　　　Else
　　　　　　CHK = 3
　　　　　End If
　　　　Else
　　　　　If .Top < MXY \ 2 Then
　　　　　　CHK = 1
　　　　　Else
　　　　　　CHK = 2
　　　　　End If
　　　　End If
　　　End With
　　Next
　End With
End Sub
'（続く）

回答No.3

end-u

すみません、ちょっと長いです。
それに完全にはほど遠く、しかも遅いです。
'---------
Option Explicit
Const PI As Double = 3.14159265358979 'π
Const LBW = 90　　　'DataLabel.Width固定
Const LBH = 36　　　'DataLabel.Height固定
Const MN = 2　　　　'配置最小値
Private MXX As Long '配置最大値ChartArea.Width
Private MXY As Long '配置最大値ChartArea.Height
Private CHK As Long '遷移方向
'---------
Sub Test()
　Dim c As ChartObject

　If Not ActiveChart Is Nothing Then Exit Sub
　For Each c In ActiveSheet.ChartObjects
　　Select Case c.Chart.ChartType
　　Case xlPie, xlPieExploded
　　　With c.Chart.SeriesCollection(1)
　　　　.ApplyDataLabels Type:=xlDataLabelsShowNone
　　　　.ApplyDataLabels Type:=xlDataLabelsShowLabelAndPercent, _
　　　　　　　　　　　　 AutoText:=True, _
　　　　　　　　　　　　 HasLeaderLines:=True
　　　　.DataLabels.Border.LineStyle = xlContinuous
　　　End With
　　　Call TestSub1(c.Chart)
　　Case Else
　　　'
　　End Select
　Next
End Sub
'---------
'DataLabelを外側へ拡げる
Sub TestSub1(ByRef cht As Chart)
　Dim mgn As Double　　'初期移動距離算出用
　Dim d　 As DataLabel
　Dim s　 As String
　Dim n　 As Double

　With cht
　　With .ChartArea
　　　MXX = .Width - MN
　　　MXY = .Height - MN
　　End With
　　With .PlotArea
　　　mgn = Application.Min(.Left, .Top) - MN
　　End With
　　With .SeriesCollection(1)
　　　For Each d In .DataLabels
　　　　s = d.Text
　　　　'外へのx,y値を%から算出して処理
　　　　n = n + (Val(Mid$(s, InStr(s, vbLf) + 1)) / 100) * 2
　　　　d.Left = d.Left + Sin(n * PI) * mgn
　　　　d.Top = d.Top - Cos(n * PI) * mgn
　　　　'閾値を超えた場合の処理
　　　　If d.Left > MXX Then
　　　　　d.Left = MN
　　　　End If
　　　　If d.Top > MXY Then
　　　　　d.Top = MN
　　　　End If
　　　Next
　　　Call TestSub2(.DataLabels)
　　End With
　End With
End Sub
'---------
'DataLabelのLoop処理
'（続く）

回答No.2

noname#164823

merlionXXさん。

いつも素晴らしい回答を拝見しております。そりゃそうですよね。

こんな過去ログをみつけました。釈迦に説法かもしれませんが。

http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+200804/08040126.txt

http://www.efcit.co.jp/cgi-bin3/exqalounge.cgi?print+200807/08070012.txt

お礼

inu-cyanさん、参考URLありがとうございます。
試行錯誤してますが、やはりあまり芳しくありません。
やっぱり難しいようですね。

回答No.1

noname#164823

マクロではなく、通常のグラフ作成の方法で宜しければ。

グラフエリアをWクリック。「グラフエリアの書式設定」
「フォント」タブの「自動サイズ調整」にチェックが入っていると、
グラフのサイズの変更に伴い、フォントもサイズが調整されて、
重ならなくなりますが、文字数が多い時は必ずしも
うまくいきません。

・フォントサイズを小さくする。
・グラフエリアとプロットエリアを広げる。
・データラベルを選択→1つのラベルを選択→ドラッグで移動する。これを
　繰り返す。

などで回避できます。

データラベルの「パターン」「輪郭」は通常「なし」ですが、
枠線が付いているので繁雑になっています。

お礼

さっそくありがとうございます。
データラベルの輪郭を無くし、フォントを小さくしてみました。
前よりはだいぶ見やすくなりましたが、データラベルの文字の重なりはどうしても出てしまいます。
もちろん手作業で修正出来るのですが、全部自動化したかったのです。
妥協するしかないのかもしれませんね。