Method to remove overlap in data labels for single series

[omahadivision]

Hi guys,



I've created a fairly simple algorithm to remove overlapping data labels on a single series in Excel. It's based on this Stack Overflow page, and it's quite effective in dealing with graphs with sometimes close-spaced single series. I'm posting it in hopes that some will find it useful and that others might have suggestions for making it more efficient.

First: I use a loop to detect which datapoints have labels, and then store the points in an array and the number of points as long:

Sub DataArray()
Dim dLabels() As DataLabel
Dim i As Long
Dim k As Long
ReDim dLabels(1 To 1868) 'my range
Set FTIRLine = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)

k = 1
For i = 1 To FTIRLine.Points.Count

   If FTIRLine.Points(i).HasDataLabel = _
         True Then 'tests to see if point has datalabel
             Set dLabels(k) = FTIRLine.Points(i).DataLabel
             k = k + 1
         End If
         Next

Call AdjustLabels(dLabels, k) 'sends labels, number of labels, to function
End sub

AdjustLabels is a function which detects overlapping labels and then separates them by raising one label up by half and lowering the other label by half. There are many different ways the labels could be moved depending on the application, and the ' left lines correspond to coding to move the labels side-to-side instead of up and down. Hight and Wdth are two arbitrary margins that determine the space the labels must be separated by and can be adjusted in twips to give greater of less distances. The code essentially tests each data label against its adjacent data label to see if they overlap.

  
Sub AdjustLabels(ByRef v() As DataLabel, ByVal m As Long)
 Dim o As Long

hight = 8.5
Wdth = 35
o = 1

Do
If v(o).Left < (v(o + 1).Left + Wdth) And v(o).Top < (v(o + 1).Top + hight) And v(o).Top > (v(o + 1).Top - hight) Then

v(o).Top = v(o).Top + hight / 2
v(o + 1).Top = v(o).Top - hight / 2

'v(o).Left = v(o).Left + Wdth / 2
'v(o + 1).Left = v(o).Left - Wdth / 2

Else

End If

o = o + 1

Loop Until o = m - 1

End sub

Now often, especially with multiple data points to a series, the labels even when they have been moved will still be overlapping. So I've created another sub which essentially repeats the first sub 5 times. I'm sure this step could be much more efficient:

Sub DataArrayCaller()
Dim q As Long
q = 1
Do
DataArray
q = q + 1
Loop Until q = 5

End Sub

The finished result below: