[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『散布図のラベルデータの重なり回避について』（AKI）
シートに以下のようなデータが入っています。
X Y
A ４ ７
B ６ １２
C１０ １６
D１０ １６
最大で40行までのデータで、X値とY値の変域はともに最小値4、最大値16です。
このデータを散布図にします。
すると、CとDのように同じX値Y値をとるデータはプロットが重なります。
それはいいのですが、データラベルをセル値にし、「A」や「B」という表示にすると、「C」と「D」という表記も当然重なって表示されます。このラベルの重なりを自動で回避する方法はありますでしょうか。
ドラッグにて移動させればよいのですが、データによっては重複値が多いものもあり、一つひとつ手作業で行うには手間がかかります。
もしくは、シート上で重複値を検索し、重複する値にはそれぞれ順番に0.1ずつ値を加算してずらし、プロットそのものをずらす……なんてことは可能でしょうか。
X Y X Y
A ４ ７ A ４ ７
B ６ １２ → B ６ １２
C１０ １６ C １０．１ １６．１
D１０ １６ D １０．２ １６．２
どなたかよいお知恵がございましたら、お貸しください。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
こんにちは。
【試し方】 データラベル付きの散布図を作成します。 ・データラベルには「セルの値」を表示し、 ・「引き込み線を引く」にチェックを入れておいて下さい。
「グラフをアクティブにした状態」で、マクロmainを実行して下さい。
結果が思わしくなければ、再度mainを実行してみて下さい。 別の選択肢がでます。
まずはバックアップを取ったうえで、試して見て下さい。 少々長いですが、ひとつの標準モジュールにコピーして使います。
【参考コード】
Option Explicit
Dim n_labels As Long Dim myRect() As Variant Dim myRect2() As Variant Dim rectidx1() As Long Dim rectidx2() As Long Dim insideWidth As Double Dim insideHeight As Double
'アクティブな散布図のデータラベルの重なりをできるだけ回避
Sub main()
Dim myChart As Chart
Set myChart = ActiveChart
Call pointLabel(myChart)
End Sub
Function pointLabel(myChart As Chart)
Dim bestDisplacement As Variant
Call getMetrics(myChart)
'ラベルの位置情報などの取得
Call getRect(myChart)
'重なりあう可能性のあるラベルのペアを取得
Call canIntersect
'焼きなまし法による最適な変位の探索
bestDisplacement = simulatedAnnealing()
'ラベルの位置を実際に動かす
Call setLabelPosition(myChart, bestDisplacement)
End Function
Function getMetrics(myChart As Chart)
insideWidth = myChart.PlotArea.insideWidth
insideHeight = myChart.PlotArea.insideHeight
End Function
'ラベルの位置情報などを取得
Sub getRect(myChart As Chart)
Dim mySeries As Series
Dim dl As DataLabel
Dim k&
Dim l#, t#, r#, b#, width#, height#
Set mySeries = myChart.SeriesCollection(1)
myChart.SetElement msoElementDataLabelCenter
'''myChart.SetElement msoElementDataLabelRight
With mySeries.DataLabels
.ShowRange = True '「セルの値」を表示
.ShowValue = False 'Y値を非表示 するものとした
End With
n_labels = mySeries.Points.Count
ReDim myRect(1 To n_labels)
ReDim myRect2(1 To n_labels)
For k = 1 To n_labels
Set dl = mySeries.Points(k).DataLabel
'位置は相対化するものとした。最後に元に戻す
l = dl.Left / insideWidth
t = dl.Top / insideHeight
width = dl.width / insideWidth
height = dl.height / insideHeight
myRect(k) = Array(l, t, l + width, t + height)
'仮にラベルの大きさが2倍だったとしたときのラベルの位置（動かす最大限）
myRect2(k) = Array(l - 0.5 * width, t - 0.5 * height, _
l + width * 1.5, t + 1.5 * height)
Next
End Sub
' 重なりあう可能性のあるラベルのペアを取得（ラベルの大きさが2倍と仮定）
'これ以外のペアはラベル位置を動かしても重なることはない。（計算負荷の軽減）
Function canIntersect()
Dim i&, j&, k&
k = 0
For i = 1 To n_labels
For j = 1 To i - 1
If rect_intersect(myRect2(i), myRect2(j)) > 0 Then
k = k + 1
ReDim Preserve rectidx1(1 To k)
ReDim Preserve rectidx2(1 To k)
rectidx1(k) = i
rectidx2(k) = j
End If
Next
Next
End Function
' 焼きなまし法による探索（返り値は、最適な変位組み合わせ）
Function simulatedAnnealing() As Variant
ReDim displacement(1 To n_labels) As Variant
Dim newdisplacement As Variant
Dim bestDisplacement As Variant
Dim score#
Dim newscore#
Dim bestscore#
Dim temperature#
Dim i&, j&, k&
Dim l#, t#
'ラベルの変位codeを８に初期設定
For k = 1 To n_labels
displacement(k) = 8
Next
score = makeScores(displacement) '「重なり度合い」の計算
bestDisplacement = displacement
bestscore = score
temperature = 0.001 ' パラメータ
For i = 1 To 50
k = 1
For j = 1 To 50
newdisplacement = displacement
'ランダムなラベルをランダムに変位させる
newdisplacement(WorksheetFunction.RandBetween(1, n_labels)) _
= WorksheetFunction.RandBetween(1, 8)
newscore = makeScores(newdisplacement)
'高温では緩い条件でも新しい変位に変更 （冒険を許す）
'（低温になるとより厳しい条件で変更する）(保守的にする）
If (newscore <= score Or Rnd() < Exp((score - newscore) / temperature)) Then
k = k + 1
score = newscore
displacement = newdisplacement
End If
If score <= bestscore Then
bestscore = score
bestDisplacement = displacement
End If
If (bestscore = 0 Or k = 10) Then Exit For
Next
If bestscore = 0 Then Exit For
temperature = 0.9 * temperature '温度を一定率で低下させる
Next
simulatedAnnealing = bestDisplacement
End Function
'ラベルどうしの「重なり度合い」を評価(ただし、対象は、重なる可能性のあるラベルのペアだけに限定）
Function makeScores(displacement) As Double
Dim area#
Dim k&
Dim rect1, rect2
area = 0
For k = 1 To UBound(rectidx1)
rect1 = myRect(rectidx1(k))
rect1 = make_rect(rect1, displacement(rectidx1(k)))
rect2 = myRect(rectidx2(k))
rect2 = make_rect(rect2, displacement(rectidx2(k)))
area = area + rect_intersect(rect1, rect2)
Next
makeScores = area
End Function
'変位 code(1～8で指定) に応じて、移動後のラベル位置を返す
Function make_rect(rect, code) As Variant
Dim l#, t#, r#, b#, width#, height#
Dim xdisp#, ydisp#
l = rect(0): t = rect(1): r = rect(2): b = rect(3)
width = r - l
height = t - b
xdisp = Array(0, -1, -1, -1, 0, 0, 1, 1, 1)(code) * width / 2#
ydisp = Array(0, -1, 0, 1, -1, 1, -1, 0, 1)(code) * height / 2#
make_rect = rect_displace(rect, xdisp, ydisp)
End Function
'ラベルの位置を指定した分だけずらす
Function rect_displace(rect, xdisp, ydisp) As Variant
rect_displace = Array(rect(0) + xdisp, rect(1) + ydisp, _
rect(2) + xdisp, rect(3) + ydisp)
End Function
'ラベル rect1 と rect2 の重なった部分の面積を返す
Function rect_intersect(rect1 As Variant, rect2 As Variant) As Double
Dim l1#, t1#, r1#, b1#
Dim l2#, t2#, r2#, b2#
Dim w#, h#
l1 = rect1(0): t1 = rect1(1): r1 = rect1(2): b1 = rect1(3)
l2 = rect2(0): t2 = rect2(1): r2 = rect2(2): b2 = rect2(3)
w = WorksheetFunction.Min(r1, r2) - WorksheetFunction.Max(l1, l2)
h = WorksheetFunction.Min(b1, b2) - WorksheetFunction.Max(t1, t2)
If w <= 0 Then
rect_intersect = 0
Exit Function
End If
If h <= 0 Then
rect_intersect = 0
Exit Function
End If
rect_intersect = w * h
End Function
Function setLabelPosition(myChart As Chart, bestDisplacement As Variant)
Dim k&
Dim l#, t#
ReDim myRectReal(1 To n_labels) As Variant
'データラベルの位置を実際に移動
For k = 1 To n_labels
myRectReal(k) = make_rect(myRect(k), bestDisplacement(k))
l = myRectReal(k)(0) * insideWidth
t = myRectReal(k)(1) * insideHeight
myChart.SeriesCollection(1).Points(k).DataLabel.Left = l
myChart.SeriesCollection(1).Points(k).DataLabel.Top = t
Next
End Function
（γ） 2020/10/21(水) 12:14
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.