Fast label placement in one dimension in VBA

README.md

This is a modified version of Jon Peltier's label placement code, using the algorithm from https://observablehq.com/@jtrim-ons/label-placement-for-a-slope-chart-2.

This code replaces the sub FixTheseLabels in Peltier's code.

Thanks to Jon Peltier for his comments, which helped me to make this code about twice as fast and to handle missing values correctly.

label-placement.vba

Sub FixTheseLabels(cht As Chart, iPoint As Long, LabelPosition As XlDataLabelPosition)
  ' Alternative implementation based on
  ' https://observablehq.com/@jtrim-ons/label-placement-for-a-slope-chart-2
  Dim Label As DataLabel
  Dim nLabels As Long
  Dim nUsedLabels As Long
  nUsedLabels = 0
  nLabels = cht.SeriesCollection.Count
  Dim vDataLabels As Variant
  ReDim vDataLabels(1 To nLabels, 1 To 2)
  Dim iLabel As Long
  For iLabel = 1 To nLabels
    Dim srs As Series
    Set srs = cht.SeriesCollection(iLabel)
    If srs.Points(iPoint).HasDataLabel Then
      Dim dlbl As DataLabel
      Set dlbl = srs.Points(iPoint).DataLabel
      If dlbl.Position <> LabelPosition Then
        dlbl.Position = LabelPosition
        DoEvents
        DoEvents
      End If
      If CStr(dlbl.Height) <> Overflow Then
        vDataLabels(iLabel, 1) = iLabel
        vDataLabels(iLabel, 2) = dlbl.Top
        nUsedLabels = nUsedLabels + 1
      Else
        vDataLabels(iLabel, 1) = 0
        vDataLabels(iLabel, 2) = 0
      End If
    Else
      vDataLabels(iLabel, 1) = 0
      vDataLabels(iLabel, 2) = 0
    End If
  Next
  BubbleSortArrayByColumn vDataLabels, 2
  
  ' vUsedDataLabels will contain the indices of only those labels with valid values
  Dim vUsedDataLabels As Variant
  ReDim vUsedDataLabels(1 To nUsedLabels, 1 To 2)
  Dim i As Long
  i = 1
  For iLabel = 1 To nLabels
    If vDataLabels(iLabel, 1) > 0 Then
      vUsedDataLabels(i, 1) = vDataLabels(iLabel, 1)  ' label index
      Set Label = cht.SeriesCollection(vUsedDataLabels(i, 1)).DataLabels(iPoint)
      vUsedDataLabels(i, 2) = Label.Top               ' label position
      i = i + 1
    End If
  Next
 
  ' Do the trick of subtracting heights
  Dim HeightSum As Double
  HeightSum = 0
  For i = 1 To nUsedLabels
    Set Label = cht.SeriesCollection(vUsedDataLabels(i, 1)).DataLabels(iPoint)
    vUsedDataLabels(i, 2) = Label.Top - HeightSum
    HeightSum = HeightSum + Label.Height * (1 - OverlapTolerance)
  Next
 
  ' Run PAVA to create batches
  Dim BB As Variant   ' Batches
  ReDim BB(1 To nUsedLabels, 1 To 2)
  Dim j As Long    ' The current number of batches
  j = 0
  For i = 1 To nUsedLabels
    j = j + 1
    BB(j, 1) = 1                        ' Size of batch
    BB(j, 2) = vUsedDataLabels(i, 2)    ' Mean position
    Do While j > 1
      If BB(j - 1, 2) < BB(j, 2) Then Exit Do
      Dim SizeSum As Double
      SizeSum = BB(j - 1, 1) + BB(j, 1)
      BB(j - 1, 2) = (BB(j - 1, 2) * BB(j - 1, 1) + BB(j, 2) * BB(j, 1)) / SizeSum
      BB(j - 1, 1) = SizeSum
      j = j - 1
    Loop
  Next
 
  ' Write positions found by PAVA to labels
  Dim labelIndex As Long
  labelIndex = 1
  For i = 1 To j
    Dim k As Long
    For k = 1 To BB(i, 1)
      vUsedDataLabels(labelIndex, 2) = BB(i, 2)
      labelIndex = labelIndex + 1
    Next
  Next
 
  ' Undo the trick of subtracting heights
  HeightSum = 0
  For i = 1 To nUsedLabels
    Set Label = cht.SeriesCollection(vUsedDataLabels(i, 1)).DataLabels(iPoint)
    Label.Top = vUsedDataLabels(i, 2) + HeightSum
    HeightSum = HeightSum + Label.Height * (1 - OverlapTolerance)
  Next
End Sub