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 Routine
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.
Option Explicit Const MoveIncrement As Double = 0.75 ' 0.75 points = 1 pixel Const OverlapTolerance As Double = 0.45 Sub ApplySlopeChartDataLabels() If ActiveChart Is Nothing Then MsgBox "Select a chart and try again!", vbExclamation GoTo ExitSub Else With ActiveChart .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 End If FixTheseLabels ActiveChart, 1, xlLabelPositionLeft FixTheseLabels ActiveChart, 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 IsNumeric(dlbl.Height) 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
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.