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:
Code:
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.
Code:
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:
Code:
Sub DataArrayCaller()
Dim q As Long
q = 1
Do
DataArray
q = q + 1
Loop Until q = 5
End Sub
The finished result below: