Excel macro for adding labels to scatterplot points while avoiding their overlap if points are close

AttachLabelsToPointsAvoidingOverlap.vba

Sub AttachLabelsToPointsAvoidingOverlap()
   ' Based on:
   ' https://support.microsoft.com/en-gb/topic/how-to-use-a-macro-to-add-labels-to-data-points-in-an-xy-scatter-chart-or-in-a-bubble-chart-in-excel-0f7642a5-fc9f-375c-94f1-953fb55eae06
   ' but significantly extended to reduce the overlap of labels for points which are close
   '
   ' IMPORTANT: The labels for the scatterplot points are assumed to be in the column directly on the left side of the data range
   ' USAGE: Select the chart (scatterplot) concerned, then run the macro
   ' If you don't like the positioning of the labels, simply re-run the macro - new positions may be better
   ' because it will be based on new random numbers.
   

   ' Dimension variables
   Dim originalChart As Chart
   Set originalChart = ActiveChart
   Dim Counter As Integer, newXval As Integer, newYval As Integer, n As Integer
   Dim xVals As String
   Dim IntPair As Variant
   Dim myPairs As Collection
   Set myPairs = New Collection

   ' Disable screen updating while the subroutine is run
   Application.ScreenUpdating = False

   'Store the formula for the first series in "xVals"
   xVals = ActiveChart.SeriesCollection(1).formula

   'Extract the range for the data from xVals
   xVals = Mid(xVals, InStr(InStr(xVals, ","), xVals, _
      Mid(Left(xVals, InStr(xVals, "!") - 1), 9)))
   xVals = Left(xVals, InStr(InStr(xVals, "!"), xVals, ",") - 1)
   Do While Left(xVals, 1) = ","
      xVals = Mid(xVals, 2)
   Loop

   'Attach a label to each data point in the chart
   For Counter = 1 To Range(xVals).Cells.Count
      ActiveChart.SeriesCollection(1).Points(Counter).HasDataLabel = _
         True
      ActiveChart.SeriesCollection(1).Points(Counter).DataLabel.formula = _
        "=" & Range(xVals).Cells(Counter, 1).Offset(0, -1).Address(External:=True)
      ActiveChart.SeriesCollection(1).Points(Counter).DataLabel.Position = _
         xlLabelPositionCenter
      ActiveChart.SeriesCollection(1).Points(Counter).DataLabel.Select
      n = 0
      newIsNotOK = True
      While newIsNotOK
        newXval = Selection.Left + 2 * RandomPlusOrMinusOne() * RandomInt(n) - 10
        newYval = Selection.Top + RandomPlusOrMinusOne() * RandomInt(n)
        newIsNotOK = TupleExists(myPairs, newXval, newYval)
        n = n + 1
      Wend
      IntPair = Array(Selection.Left, Selection.Top) ' to avoid future overlaps with points
      myPairs.Add IntPair
      IntPair = Array(newXval, newYval) ' to avoid future overlaps with labels
      myPairs.Add IntPair
      Selection.Left = newXval
      Selection.Top = newYval
   Next Counter
            
   ' Enable screen updating.
   Application.ScreenUpdating = True

End Sub

AttachLabelsToPointsAvoidingOverlapWithCustomLabelRange.vba

Sub AttachLabelsToPointsAvoidingOverlapWithCustomLabelRange()
   ' Based on:
   ' https://support.microsoft.com/en-gb/topic/how-to-use-a-macro-to-add-labels-to-data-points-in-an-xy-scatter-chart-or-in-a-bubble-chart-in-excel-0f7642a5-fc9f-375c-94f1-953fb55eae06
   ' but significantly extended to reduce the overlap of labels for points which are close
   '
   ' USAGE: Select the chart (scatterplot) concerned, then run the macro
   ' If you don't like the positioning of the labels, simply re-run the macro - new positions may be better
   ' because it will be based on new random numbers.
   

   ' Dimension variables
   Dim originalChart As Chart
   Set originalChart = ActiveChart
   Dim Counter As Integer, newXval As Integer, newYval As Integer, n As Integer
   Dim xVals As String
   Dim IntPair As Variant
   Dim myPairs As Collection
   Set myPairs = New Collection

       
    ' Ask the user for the label range.
    Set labelRange = Application.InputBox("Select the range of labels", Type:=8)
    

   ' Disable screen updating while the subroutine is run
   Application.ScreenUpdating = False

   'Store the formula for the first series in "xVals"
   xVals = ActiveChart.SeriesCollection(1).formula

   'Extract the range for the data from xVals
   xVals = Mid(xVals, InStr(InStr(xVals, ","), xVals, _
      Mid(Left(xVals, InStr(xVals, "!") - 1), 9)))
   xVals = Left(xVals, InStr(InStr(xVals, "!"), xVals, ",") - 1)
   Do While Left(xVals, 1) = ","
      xVals = Mid(xVals, 2)
   Loop

   'Attach a label to each data point in the chart
   For Counter = 1 To labelRange.Cells.Count
      ActiveChart.SeriesCollection(1).Points(Counter).HasDataLabel = _
         True
      ActiveChart.SeriesCollection(1).Points(Counter).DataLabel.formula = _
        "=" & Range(xVals).Cells(Counter, 1).Offset(0, -1).Address(External:=True)
      ActiveChart.SeriesCollection(1).Points(Counter).DataLabel.Position = _
         xlLabelPositionCenter
      ActiveChart.SeriesCollection(1).Points(Counter).DataLabel.Select
      n = 0
      newIsNotOK = True
      While newIsNotOK
        newXval = Selection.Left + 2 * RandomPlusOrMinusOne() * RandomInt(n) - 10
        newYval = Selection.Top + RandomPlusOrMinusOne() * RandomInt(n)
        newIsNotOK = TupleExists(myPairs, newXval, newYval)
        n = n + 1
      Wend
      IntPair = Array(Selection.Left, Selection.Top) ' to avoid future overlaps with points
      myPairs.Add IntPair
      IntPair = Array(newXval, newYval) ' to avoid future overlaps with labels
      myPairs.Add IntPair
      Selection.Left = newXval
      Selection.Top = newYval
   Next Counter

    ' Enable screen updating.
    Application.ScreenUpdating = True

End Sub

helper_functions.vba

Function RandomInt(n As Integer) As Integer
    Randomize ' Initialize the random number generator
    RandomInt = Int(Rnd * n) + 7
End Function

Function RandomPlusOrMinusOne() As Integer
    Randomize ' Initialize the random number generator
    If Rnd < 0.5 Then
        RandomPlusOrMinusOne = -1
    Else
        RandomPlusOrMinusOne = 1
    End If
End Function

Function TupleExists(myPairs As Collection, a As Integer, b As Integer) As Boolean
    Dim i As Integer
    Dim pair As Variant

    For i = 1 To myPairs.Count ' Collections in VBA are 1-based
        pair = myPairs.item(i)
        xVal = pair(0)
        yVal = pair(1)
        If Abs(xVal - a) <= 30 And Abs(yVal - b) <= 15 Then
            TupleExists = True
            Exit Function
        End If
    Next i

    TupleExists = False

End Function