Excel XY Chart (Scatter plot) Data Label No Overlap

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:

Answer 1

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