Excel XY Chart (Scatter plot) Data Label No Overlap - vba

Question

So I've been working on this for the past week. Although it can't do miracles, I can say I've got a pretty good result:
I just wanted to put this code out there for all the poor souls like me that are looking for some kind of vba macro that helps them avoid label overlaps in a scatter plot, because while doing my research on the subject, I wasn't able to find anything helpful.

Answer 1

Const PIXEL_TO_POINT_RATIO As Double = 0.72 '1 Pixel = 72/96*1 Point
Const tStep As Double = 0.1
Const rStep As Double = 0.1
Dim pCount As Integer
Sub ExampleMain()
RearrangeScatterLabels Sheet5
RearrangeScatterLabels Sheet25
End Sub
Sub RearrangeScatterLabels(sht As Worksheet)
Dim plot As Chart
Dim sCollection As SeriesCollection
Dim dLabels() As DataLabel
Dim dPoints() As Point
Dim xArr(), yArr(), stDevX, stDevY As Double
Dim x0, x1, y0, y1 As Double
Dim temp() As Double
Dim theta As Double
Dim r As Double
Dim isOverlapped As Boolean
Dim safetyNet, validEntry, currentPoint As Integer
Set plot = sht.ChartObjects(1).Chart 'XY chart (scatter plot)
Set sCollection = plot.SeriesCollection 'All points and labels
safetyNet = 1
pCount = (sCollection.Count - 1)
ReDim dLabels(1 To 1)
ReDim dPoints(1 To 1)
ReDim xArr(1 To 1)
ReDim yArr(1 To 1)
For pt = 1 To sCollection(1).Points.Count
For i = 1 To pCount
If sCollection(i).Points.Count <> 0 Then
'Dynamically expand the arrays
validEntry = validEntry + 1
If validEntry <> 1 Then
ReDim Preserve dLabels(1 To UBound(dLabels) + 1)
ReDim Preserve dPoints(1 To UBound(dPoints) + 1)
ReDim Preserve xArr(1 To UBound(xArr) + 1)
ReDim Preserve yArr(1 To UBound(yArr) + 1)
End If
Set dLabels(i) = sCollection(i).Points(pt).DataLabel 'Store all label objects
Set dPoints(i) = sCollection(i).Points(pt) 'Store all point objects
temp = getElementDimensions(, dPoints(i))
xArr(i) = temp(0) 'Store all points x values
yArr(i) = temp(2) 'Store all points y values
End If
Next
Next
If UBound(dLabels) < 2 Then Exit Sub
pCount = UBound(dLabels)
stDevX = Application.WorksheetFunction.StDev(xArr) 'Get standard deviation for x
stDevY = Application.WorksheetFunction.StDev(yArr) 'Get standard deviation for y
If stDevX = 0 Then stDevX = 1
If stDevY = 0 Then stDevY = 1
r = 0
For currentPoint = 1 To pCount
theta = Rnd * 2 * Application.WorksheetFunction.Pi()
x0 = xArr(currentPoint)
y0 = yArr(currentPoint)
x1 = xArr(currentPoint)
y1 = yArr(currentPoint)
isOverlapped = True
Do Until Not isOverlapped
safetyNet = safetyNet + 1
If safetyNet < 500 Then
If Not checkForOverlap(dLabels(currentPoint), dLabels, dPoints, plot) Then
'No label is within bounds and not overlapping
isOverlapped = False
r = 0
theta = Rnd * 2 * Application.WorksheetFunction.Pi()
safetyNet = 1
Else
'Move label so it does not overlap
theta = theta + tStep
r = r + rStep * tStep / (2 * Application.WorksheetFunction.Pi())
x1 = x0 + stDevX * r * Cos(theta)
y1 = y0 + stDevY * r * Sin(theta)
dLabels(currentPoint).Left = x1
dLabels(currentPoint).Top = y1
End If
Else
safetyNet = 1
Exit Do
End If
Loop
Next
End Sub
Function checkForOverlap(ByRef dLabel As DataLabel, ByRef dLabels() As DataLabel, ByRef dPoints() As Point, ByRef dChart As Chart) As Boolean
checkForOverlap = False 'Return false by default
'Detect label going over chart area
If detectOverlap(dLabel, , , dChart) Then
checkForOverlap = True
Exit Function
End If
'Detect labels overlap
For i = 1 To pCount
If Not dLabel.Left = dLabels(i).Left Then
If detectOverlap(dLabel, dLabels(i)) Then
checkForOverlap = True
Exit Function
End If
End If
Next
'Detect label overlap with point
For i = 1 To pCount
If detectOverlap(dLabel, , dPoints(i)) Then
checkForOverlap = True
Exit Function
End If
Next
End Function
Function getElementDimensions(Optional dLabel As DataLabel, Optional dPoint As Point, Optional dChart As Chart) As Double()
'Get element dimensions and compensate slack
Dim eDimensions(3) As Double
'Working in IV quadrant
If dPoint Is Nothing And dChart Is Nothing Then
'Get label dimensions and compensate padding
eDimensions(0) = dLabel.Left + PIXEL_TO_POINT_RATIO * 3 'Left
eDimensions(1) = dLabel.Left + dLabel.Width - PIXEL_TO_POINT_RATIO * 3 'Right
eDimensions(2) = dLabel.Top + PIXEL_TO_POINT_RATIO * 6 'Top
eDimensions(3) = dLabel.Top + dLabel.Height - PIXEL_TO_POINT_RATIO * 3 'Bottom
End If
If dLabel Is Nothing And dChart Is Nothing Then
'Get point dimensions
eDimensions(0) = dPoint.Left - PIXEL_TO_POINT_RATIO * 5 'Left
eDimensions(1) = dPoint.Left + PIXEL_TO_POINT_RATIO * 5 'Right
eDimensions(2) = dPoint.Top - PIXEL_TO_POINT_RATIO * 5 'Top
eDimensions(3) = dPoint.Top + PIXEL_TO_POINT_RATIO * 5 'Bottom
End If
If dPoint Is Nothing And dLabel Is Nothing Then
'Get chart dimensions
eDimensions(0) = dChart.PlotArea.Left + PIXEL_TO_POINT_RATIO * 22 'Left
eDimensions(1) = dChart.PlotArea.Left + dChart.PlotArea.Width - PIXEL_TO_POINT_RATIO * 22 'Right
eDimensions(2) = dChart.PlotArea.Top - PIXEL_TO_POINT_RATIO * 4 'Top
eDimensions(3) = dChart.PlotArea.Top + dChart.PlotArea.Height - PIXEL_TO_POINT_RATIO * 4 'Bottom
End If
getElementDimensions = eDimensions 'Return dimensions array in Points
End Function
Function detectOverlap(ByVal dLabel1 As DataLabel, Optional ByVal dLabel2 As DataLabel, Optional ByVal dPoint As Point, Optional ByVal dChart As Chart) As Boolean
'Left, Right, Top, Bottom
Dim AxL, AxR, AyT, AyB As Double 'First label coordinates
Dim BxL, BxR, ByT, ByB As Double 'Second label coordinates
Dim eDimensions() As Double 'Element dimensions
eDimensions = getElementDimensions(dLabel1)
AxL = eDimensions(0)
AxR = eDimensions(1)
AyT = eDimensions(2)
AyB = eDimensions(3)
If dPoint Is Nothing And dChart Is Nothing Then
'Compare with another label
eDimensions = getElementDimensions(dLabel2)
End If
If dLabel2 Is Nothing And dChart Is Nothing Then
'Compare with a point
eDimensions = getElementDimensions(, dPoint)
End If
If dPoint Is Nothing And dLabel2 Is Nothing Then
'Compare with chart area
eDimensions = getElementDimensions(, , dChart)
End If
BxL = eDimensions(0)
BxR = eDimensions(1)
ByT = eDimensions(2)
ByB = eDimensions(3)
If dChart Is Nothing Then
detectOverlap = (AxL <= BxR And AxR >= BxL And AyT <= ByB And AyB >= ByT) 'Reverse De Morgan's Law
Else
detectOverlap = Not (AxL >= BxL And AxR <= BxR And AyT >= ByT And AyB <= ByB) 'Is in chart bounds (working in IV quadrant)
End If
End Function
I realize the code is kinda rough and not optimized, but I can't spend more time on this project. I've left quite a few notes around to help read it, should anyone choose to continue this project. Hope this helps.
Best wishes, Schadenfreude.

Answer 2

Building on your function, I made a routine to randomly reposition the labels, assigning a score according to how much overlap it would cause, and thusly optimize. The results aren't great for my own data set, but I think it can be tuned easily for most usages.
There are some issues with the borders and the axis labels which maybe I'll account for later.
Option Explicit
Sub ExampleUsage()
RearrangeScatterLabels ActiveSheet.ChartObjects(1).Chart, 3
End Sub
Sub RearrangeScatterLabels(plot As Chart, Optional timelimit As Double = 5)
Dim sCollection As SeriesCollection
Set sCollection = plot.SeriesCollection
Dim pCount As Integer
pCount = sCollection(1).Points.Count
If pCount < 2 Then Exit Sub
Dim dPoints() As Point
Dim xArr() As Double ' Label center position X
Dim yArr() As Double ' Label center position Y
Dim wArr() As Double ' Label width
Dim hArr() As Double ' Label height
Dim pArr() As Double ' Marker position X
Dim qArr() As Double ' Marker position Y
Dim mArr() As Double ' Markersize
ReDim dPoints(1 To pCount)
ReDim xArr(1 To pCount)
ReDim yArr(1 To pCount)
ReDim wArr(1 To pCount)
ReDim hArr(1 To pCount)
ReDim pArr(1 To pCount)
ReDim qArr(1 To pCount)
ReDim mArr(1 To pCount)
Dim theta As Double
Dim i As Integer
Dim j As Integer
Dim dblStart As Double
' Loop through all points to get their handles and coordinates
For i = 1 To pCount
' Store all point objects
Set dPoints(i) = sCollection(1).Points(i)
' Extract their coordinates and size
pArr(i) = dPoints(i).Left
qArr(i) = dPoints(i).Top
mArr(i) = dPoints(i).MarkerSize
' Store the size of the corresponding labels
wArr(i) = dPoints(i).DataLabel.Width
hArr(i) = dPoints(i).DataLabel.Height
' Starting position (center of label) is middle below
xArr(i) = pArr(i)
yArr(i) = qArr(i) + mArr(i)
Next
Dim newX As Double
Dim newY As Double
Dim dE As Double
Dim wgtOverlap As Double
Dim wgtDistance As Double
Dim wgtClose As Double
wgtOverlap = 10000 ' Extra penalty for overlapping
wgtDistance = 10000 ' Penalty for being nearby other labels
wgtClose = 10 ' Penalty for being further from marker
' Limit the function by time
dblStart = Timer
Do Until TimerDiff(dblStart, Timer) > timelimit
' Pick a random label to move around
i = Int(Rnd * pCount + 1)
' Pick a new random position by angle
theta = Rnd * 2 * Application.WorksheetFunction.Pi()
' Determine the position it would shift to
If Abs(Sin(theta) * wArr(i)) > Abs(hArr(i) * Cos(theta)) Then
' above or below
If Sin(theta) > 0 Then
' above
newX = pArr(i) + wArr(i) * Cos(theta) / 2
newY = qArr(i) - hArr(i) / 2 - mArr(i) / 2
Else
' below
newX = pArr(i) + wArr(i) * Cos(theta) / 2
newY = qArr(i) + hArr(i) / 2 + mArr(i) / 2
End If
Else
' left or right side
If Cos(theta) < 0 Then
' left
newX = pArr(i) - wArr(i) / 2 - mArr(i) / 2
newY = qArr(i) - hArr(i) * Sin(theta) / 2
Else
' right
newX = pArr(i) + wArr(i) / 2 + mArr(i) / 2
newY = qArr(i) - hArr(i) * Sin(theta) / 2
End If
End If
' Determine increase in energy caused by this shift
dE = 0
For j = 1 To pCount
If i <> j Then
' Current overlap with labels
If 2 * Abs(xArr(i) - xArr(j)) < wArr(i) + wArr(j) _
And 2 * Abs(yArr(i) - yArr(j)) < hArr(i) + hArr(j) Then
dE = dE - Abs(xArr(i) - xArr(j) + (wArr(i) + wArr(j)) / 2) _
* Abs(yArr(i) - yArr(j) + (hArr(i) + hArr(j)) / 2)
dE = dE - wgtOverlap
End If
' New overlap with labels
If 2 * Abs(newX - xArr(j)) < wArr(i) + wArr(j) _
And 2 * Abs(newY - yArr(j)) < hArr(i) + hArr(j) Then
dE = dE + Abs(newX - xArr(j) + (wArr(i) + wArr(j)) / 2) _
* Abs(newY - yArr(j) + (hArr(i) + hArr(j)) / 2)
dE = dE + wgtOverlap
End If
' Current overlap with labels
If Abs(xArr(i) - pArr(j)) < wArr(i) / 2 + mArr(j) _
And Abs(yArr(i) - qArr(j)) < hArr(i) / 2 + mArr(j) Then
dE = dE - wgtOverlap
End If
' New overlap with points
If Abs(newX - pArr(j)) < wArr(i) / 2 + mArr(j) _
And Abs(newY - qArr(j)) < hArr(i) / 2 + mArr(j) Then
dE = dE + wgtOverlap
End If
' We like the neighbours to be far away
dE = dE - wgtDistance / ((xArr(i) - xArr(j)) ^ 2 + (yArr(i) - yArr(j)) ^ 2)
dE = dE + wgtDistance / ((newX - xArr(j)) ^ 2 + (newY - yArr(j)) ^ 2)
End If
' We like the offsets to be low
dE = dE - wgtClose * (Abs(xArr(i) - pArr(i)) + Abs(yArr(i) - qArr(i)))
dE = dE + wgtClose * (Abs(newX - pArr(i)) + Abs(newY - qArr(i)))
Next
' If it didn't get worse, adjust to new position
If dE <= 0 Then
xArr(i) = newX
yArr(i) = newY
End If
Loop
' Actually adjust the labels
For i = 1 To pCount
dPoints(i).DataLabel.Left = xArr(i) - wArr(i) / 2
dPoints(i).DataLabel.Top = yArr(i) - hArr(i) / 2
Next
End Sub
' Timer function from Peter Albert
' http://stackoverflow.com/questions/15634623
Function TimerDiff(dblTimerStart As Double, dblTimerEnd As Double)
Dim dblTemp As Double
dblTemp = dblTimerEnd - dblTimerStart
If dblTemp < -43200 Then
dblTemp = dblTemp + 86400
End If
TimerDiff = dblTemp
End Function