Excel XY plot (scatter plot) Data label No overlap

Question

So, I worked on this last week. Although I cannot work miracles, I can say that I have a good result: I just wanted to put this code there for all poor souls like me who are looking for some kind of vba macro that helps them avoid overlapping labels in terms of scattering, because when I did my research on this, I could not find anything useful.

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 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 understand that the code looks rude and not optimized, but I can’t spend more time on this project. I left a few notes to help read it if someone decides to continue this project.

Hope this helps.
Best regards, Schadenfreude.

Answer 2

Based on your function, I made a routine to randomly move labels, assigning a rating according to how much it overlaps, and therefore optimizes. The results are not very good for my own data set, but I think that it can be easily customized for most applications.

There are some problems with borders and axis labels, which maybe I'll take into account 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