No.6ベストアンサー
- 回答日時:
Sub Test スタート(ChartObjectのLoopとチェック)
Sub TestSub1 DataLabelを一旦外側へバランスよく配置する
Sub TestSub2 DataLabelをLoopして重ならないように再配置する
Function TestFunc1 DataLabelの重なり判定
Function TestFunc2 重なり解消の遷移(逆Loop)
Function TestFunc3 重なり解消の遷移(順Loop)
6個のプロシージャに分けて書いてます。
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
- 回答日時:
'(続き)
'---------
'重なり判定
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
- 回答日時:
'(続き)
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
- 回答日時:
すみません、ちょっと長いです。
それに完全にはほど遠く、しかも遅いです。
'---------
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
- 回答日時:
merlionXXさん。
いつも素晴らしい回答を拝見しております。そりゃそうですよね。
こんな過去ログをみつけました。釈迦に説法かもしれませんが。
http://park7.wakwak.com/~efc21/cgi-bin/exqaloung …
http://www.efcit.co.jp/cgi-bin3/exqalounge.cgi?p …
inu-cyanさん、参考URLありがとうございます。
試行錯誤してますが、やはりあまり芳しくありません。
やっぱり難しいようですね。
No.1
- 回答日時:
マクロではなく、通常のグラフ作成の方法で宜しければ。
グラフエリアをWクリック。「グラフエリアの書式設定」
「フォント」タブの「自動サイズ調整」にチェックが入っていると、
グラフのサイズの変更に伴い、フォントもサイズが調整されて、
重ならなくなりますが、文字数が多い時は必ずしも
うまくいきません。
・フォントサイズを小さくする。
・グラフエリアとプロットエリアを広げる。
・データラベルを選択→1つのラベルを選択→ドラッグで移動する。これを
繰り返す。
などで回避できます。
データラベルの「パターン」「輪郭」は通常「なし」ですが、
枠線が付いているので繁雑になっています。
さっそくありがとうございます。
データラベルの輪郭を無くし、フォントを小さくしてみました。
前よりはだいぶ見やすくなりましたが、データラベルの文字の重なりはどうしても出てしまいます。
もちろん手作業で修正出来るのですが、全部自動化したかったのです。
妥協するしかないのかもしれませんね。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) エクセルの散布図で新たに入力した値のデータラベルが空欄になる現象 1 2022/04/26 09:31
- 計算機科学 エクセルのデータの表すことについて 2 2023/03/05 20:49
- Excel(エクセル) 図のような散布図の作り方を教えてください。 1 2022/07/19 11:52
- Excel(エクセル) エクセルのグラフに上下限値の横棒を表示させたい 5 2022/12/12 11:09
- Excel(エクセル) Excelグラフについて 1 2022/06/16 16:06
- Word(ワード) 数値に差のあるデータを分かりやすく比較する方法について。医療現場におけるヒヤリハットの発生件数を事例 3 2022/07/18 14:24
- PowerPoint(パワーポイント) ExcelのグラフをPowerPointに貼り付けした際にデータテーブルの小数点以下を削除したいです 2 2023/02/28 19:46
- Excel(エクセル) エクセルの大きなシートでグラフを見つける 4 2022/07/28 10:07
- Excel(エクセル) エクセルのイベントVBAを複数のシートで動かしたい 1 2022/12/07 16:55
- Excel(エクセル) Excelグラフについて 1 2023/05/12 16:26
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルの主軸と第2軸の0を合...
-
エクセルで円グラフに引き出し...
-
excelグラフでデータテーブルを...
-
エクセルの散布図 近似曲線の...
-
エクセルのグラフ作成時に、折...
-
EXCELグラフで「#N/A」が表示さ...
-
Excelグラフを並べ替えた時の色...
-
EXCELの円グラフで引き出し線を...
-
パワーポイントグラフのラベル...
-
パワーポイントにグラフを挿入...
-
グラフの項目軸の表示が表の表...
-
スペック足りてるのにゲームが...
-
Excelのグラフについて教えてく...
-
Excelの凡例を自由に編集する方法
-
エクセルの主軸と第2軸の0を合...
-
Excel2010 散布図 でベタ色指定
-
エクセルグラフについて(日付...
-
Excelのグラフの縦軸の文字がき...
-
エクセルのグラフ
-
エクセルの散布図で新たに入力...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセルの主軸と第2軸の0を合...
-
エクセルで円グラフに引き出し...
-
excelグラフでデータテーブルを...
-
エクセルのグラフ作成時に、折...
-
1.0未満のデータラベルを自動的...
-
Excelの凡例を自由に編集する方法
-
Excelグラフを並べ替えた時の色...
-
エクエルの折れ線グラフ
-
パワーポイントグラフのラベル...
-
パワーポイントにグラフを挿入...
-
スペック足りてるのにゲームが...
-
EXCELグラフで「#N/A」が表示さ...
-
Excel2010 散布図 でベタ色指定
-
エクセルの散布図で新たに入力...
-
エクセルのグラフ(2Y軸)の凡...
-
Excel2007グラフの軸ラベルで、...
-
エクセルグラフについて(日付...
-
エクセルで作ったグラフの項目...
-
EXCELで折れ線グラフを作る
-
エクセルの主軸と第2軸の0を合...
おすすめ情報