VBA

Overlapping Data Labels

Data labels are terribly tedious to apply to slope charts, since these labels have to be positioned to the left of the first point and to the right of the last point of each series. This means the labels have to be tediously selected one by one, even to apply “standard” alignments.

I recently wrote a post called Slope Chart with Data Labels which provided a simple VBA procedure to add data labels to a slope chart; the procedure simplified the problem caused by positioning each data label individually for each point in the chart.

The problem is that often points are located close to each other; the result: overlapping data labels. I showed a feature in my commercial software that lets you fine-tune the position of individual data labels. But even with that helpful tool, it is still a tedious process.

A more inclusive VBA procedure that would take care of overlapping data labels is a much more difficult task. I thought about it for a while. Since each set of labels is aligned horizontally with the points they describe, I would only have to worry about vertical positioning. I would have to sort the labels by vertical position, then see if a label overlapped any subsequent label. Also, I should allow some overlap, since labels include a small white margin around their text. But it seemed like a lot of work.

My friend and colleague Andy Pope came to the rescue. He sent an email with a nifty VBA routine he’d worked out. I remembered that long ago Andy had a prototype label untangler, and I know I played with it. But what he sent me now was much better than a prototype. I tested it and liked it, then I thought about how I would build my own.

Andy’s routine used a class module to create a DataLabel object for each label that had to be realigned. His routine inserts each DataLabel object into a VBA Collection in such a way that the Collection is sorted by vertical position. Then the code loops through the labels: if two were to overlap, the upper label is moved up a tiny bit and the lower one down a little bit. This must be done iteratively because moving two labels apart might move either one closer to a third label. After looping until all labels were separated by a certain amount, the code finishes.

I decided to build a slightly different routine, because I already have a slope chart feature in my commercial software (which will be released in a new build soon), and I’d like something that worked with it. To compile all the labels, the program builds a two-column VBA array, with series numbers in the first column and vertical position in the second. The code bubble-sorts this array by the second column. Then it loops through the series numbers in a nested loop, to compare each label with every other label.

The VBA Routines

My entire module is shown below. I declare a couple of constants used in the positioning. When I move labels I do so by a pixel at a time, which in Windows is specified by MoveIncrement = 0.75 (0.75 points, to be exact). If I want to run this on a Mac, I must change MoveIncrement to 1, because this is how the Mac measures screen distances (one of the myriad incompatibilities we have to deal with). After a few trials, I set an OverlapTolerance of 0.45, meaning I would let labels overlap by 45% of their height.

The routine that does the work is FixTheseLabels. It first loops through the series of the chart, and if the series has a valid label on the point being tested (we text point 1 for the left side labels and point 2 for the right), then the series number and the top position of the label are stored in the array. If the series has no valid data label, then zeros are stored in the array.

When the array is populated, the code calls BubbleSortArrayByColumn (a routine I cobbled together years ago) to sort by the top position of the labels. After sorting the labels, the label top position in the second column of the array is no longer needed.

The code loops through the array, getting the series number from the first column; if it reads a zero, it means there isn’t a valid label, so it skips to the next array row. The program gets one label from the first loop and one from the second. If the top of the second label is less than OverlapTolerance (0.45 or 45%) higher than the bottom position of the first, the first label moves up and the second moves down.

Two lines have been inserted before the ExitSub label in the ApplySlopeChartDataLabels that call the new FixTheseLabels procedure to eliminate overlapping.

The entire code module is shown below. Here is a list of the procedures and what they do.

• ApplySlopeChartDataLabelsToActiveChart
  Apply Data Labels to Active Chart, and Correct Overlaps
  Can be called using Alt+F8
  
• ApplySlopeChartDataLabelsInActiveSheet
  Apply Data Labels to Charts on Active Sheet, and Correct Overlaps
  Can be called using Alt+F8
  
• ApplySlopeChartDataLabelsInActiveWorkbook
  Apply Data Labels to Charts on Active Sheet, and Correct Overlaps
  Can be called using Alt+F8
  
• ApplySlopeChartDataLabelsToChart(cht As Chart)
Apply Data Labels to Chart cht
  Called by other code, e.g., ApplySlopeChartDataLabelsToActiveChart
  
• FixTheseLabels(cht As Chart, iPoint As Long, LabelPosition As XlDataLabelPosition)
  Correct Overlaps in Data Labels of Chart cht
  Called by Procedure ApplySlopeChartDataLabelsToChart
  
• BubbleSortArrayByColumn(MyArray As Variant, iSortCol As Long)
  Sorts List of Data Labels by Vertical Position
  Called by Procedure FixTheseLabels

The first three procedures are helper procedures which the user can run to process the active chart, all charts on the active sheet, or all charts on all worksheets in the active workbook. They can easily be accessed with the shortcut Alt+F8 or by clicking the Macros button on the Developer tab, to open the Macro dialog.

Start of Entire Code Module

Option Explicit

Const MoveIncrement As Double = 0.75 ' 0.75 points = 1 pixel
Const OverlapTolerance As Double = 0.45
Const Overflow As String = "-nan(ind)"

Sub ApplySlopeChartDataLabelsToActiveChart()
  ApplySlopeChartDataLabelsToChart ActiveChart
End Sub

Sub ApplySlopeChartDataLabelsInActiveSheet()
  ApplySlopeChartDataLabelsInSheet ActiveSheet
End Sub

Sub ApplySlopeChartDataLabelsInActiveWorkbook()
  Dim ws As Worksheet
  For Each ws In ActiveWorkbook.Worksheets
    ApplySlopeChartDataLabelsInSheet ws
  Next
End Sub

Sub ApplySlopeChartDataLabelsInSheet(ws As Worksheet)
  Dim chob As ChartObject
  For Each chob In ws.ChartObjects
    ApplySlopeChartDataLabelsToChart chob.Chart
  Next
End Sub

Sub ApplySlopeChartDataLabelsToChart(cht As Chart)
  With cht
    .HasLegend = False
    Dim iSeries As Long
    For iSeries = 1 To .SeriesCollection.Count
      With .SeriesCollection(iSeries)
        Dim iColor As Long
        iColor = .Format.Line.ForeColor.RGB
        .HasDataLabels = True
        .HasLeaderLines = True
        With .DataLabels
          .ShowValue = True
          .ShowSeriesName = True
          .Font.Color = iColor
          .Format.TextFrame2.WordWrap = False
          With .Item(1)
            .Position = xlLabelPositionLeft
          End With
          With .Item(2)
            .Position = xlLabelPositionRight
          End With
        End With
      End With
    Next
  End With
  FixTheseLabels cht, 1, xlLabelPositionLeft
  FixTheseLabels cht, 2, xlLabelPositionRight
ExitSub:
End Sub

Sub FixTheseLabels(cht As Chart, iPoint As Long, LabelPosition As XlDataLabelPosition)
  Dim nLabels As Long
  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
      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

  Do
    Dim DidNotOverlap As Boolean
    DidNotOverlap = True
    Dim FirstIndex As Long, SecondIndex As Long
    For FirstIndex = 1 To nLabels - 1
      If vDataLabels(FirstIndex, 1) > 0 Then
        Dim FirstLabel As DataLabel
        Set FirstLabel = cht.SeriesCollection(vDataLabels(FirstIndex, 1)). _
          DataLabels(iPoint)
        For SecondIndex = FirstIndex + 1 To nLabels
          If vDataLabels(SecondIndex, 1) > 0 Then
            Dim SecondLabel As DataLabel
            Set SecondLabel = cht.SeriesCollection(vDataLabels(SecondIndex, 1)). _
              DataLabels(iPoint)
            If FirstLabel.Top + FirstLabel.Height * (1 - OverlapTolerance) > _
              SecondLabel.Top Then
              DidNotOverlap = False
              FirstLabel.Top = FirstLabel.Top - MoveIncrement
              SecondLabel.Top = SecondLabel.Top + MoveIncrement
            End If
          End If
        Next
      End If
    Next
    If DidNotOverlap Then Exit Do
    Dim LoopCounter As Long
    LoopCounter = LoopCounter + 1
    If LoopCounter > 30 * nLabels Then Exit Do
  Loop
End Sub

Sub BubbleSortArrayByColumn(MyArray As Variant, iSortCol As Long)
  Dim FirstItem As Long, LastItem As Long
  FirstItem = LBound(MyArray, 1)
  LastItem = UBound(MyArray, 1)
  Dim LastSwap As Long
  LastSwap = LastItem
  Do
    Dim LoopCounter As Long
    LoopCounter = 1 + LoopCounter
    If LoopCounter > 10000 Then Exit Do
    Dim IndexLimit As Long
    IndexLimit = LastSwap - 1
    LastSwap = 0
    Dim iRow As Long
    For iRow = FirstItem To IndexLimit
      If (MyArray(iRow, iSortCol) > MyArray(iRow + 1, iSortCol)) Then
        ' if the items are not in order, swap them
        Dim jCol As Long
        For jCol = LBound(MyArray, 2) To UBound(MyArray, 2)
          Dim TempValue As Variant
          TempValue = MyArray(iRow, jCol)
          MyArray(iRow, jCol) = MyArray(iRow + 1, jCol)
          MyArray(iRow + 1, jCol) = TempValue
        Next
        LastSwap = iRow
      End If
    Next
  Loop While LastSwap
End Sub

End of Entire Code Module

The Result

Here is the chart with overlapping data labels, before running FixTheseLabels. Half of the labels are illegible.

Here is the chart after running the routine, without allowing any overlap between labels (OverlapTolerance = zero). All labels can be read, but the space between them is greater than needed (you could almost stick another label between any two adjacent labels here), and some labels have moved far from the points they label.

Finally, here is the chart after running the routine with OverlapTolerance = 0.45. Labels are closer together, but not too close, and some labels did not have to be moved (for example, see the lowest three labels on the right side of the chart). I tried a series of values for the overlap tolerance: zero tolerance obviously led to excessive spacing, 50% led to labels being a little too close, 40% was a little too far apart and some labels were moved that shouldn’t have to be. 45% seems to be the Goldilocks setting, though this probably varies with the font used for the labels.

Related Posts

• Apply Custom Data Labels to Charted Points
• Label Each Series in a Chart
• Label Last Point for Excel 2007
• Add Totals to Stacked Bar Chart