Excel XY Chart (Scatter plot) Data Label No Overlap

Hi everyone!

I have a problem that someone else has solved, but they posted the solution on a forum where I cannot comment or contact the originator even with account.

I have some scatter charts that have overlapping labels, like as follows:
Screen Shot 2017-02-22 at 3.26.43 PM.png

I'm trying to find a macro that will allow me to click on a chart, press a button and then the labels wiggle out of the way from overlapping. The code that follows from a guy/gal named TacoV at Stack Overflow follows, and it reports to do the trick nicely:

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

However if I try to run it in Excel 2016, I get an Overflow 6 with an arrow on the line in bold above.

Does anyone know how to fix that issue? I really would ask the folks on that post, but they don't allow me to do so! Thanks!