Excel macro to fix overlapping data labels in line chart

Question

I am searching/trying to make a macro to fix the position of data labels in a line chart with one or multiple series collections so that they will not overlap each other.

I was thinking of some ways for my macro but when I try to make it I understand that this is way too hard for me and I get headache.

Is there anything that I missed? Do you know about such a macro?

Here's an example chart with overlapped data labels:

Here's an example chart where I manually fixed the data labels:

Answer 1

This task basically breaks down to two steps: access the Chart object to get the Labels, and manipulate the label positions to avoid overlap.

For the sample given all series are plotted on a common X-axis and the X values are sufficiently spread that labels don't overlap in this dimension. Therefore the solution offered only deals with groups of labels for each X point in turn.

Accessing the Labels

This Sub parses the chart and creates an array of Labels for each X point in turn

Sub MoveLabels()
    Dim sh As Worksheet
    Dim ch As Chart
    Dim sers As SeriesCollection
    Dim ser As Series
    Dim i As Long, pt As Long
    Dim dLabels() As DataLabel

    Set sh = ActiveSheet
    Set ch = sh.ChartObjects("Chart 1").Chart
    Set sers = ch.SeriesCollection

    ReDim dLabels(1 To sers.Count)
    For pt = 1 To sers(1).Points.Count
        For i = 1 To sers.Count
            Set dLabels(i) = sers(i).Points(pt).DataLabel
        Next
        AdjustLabels dLabels  ' This Sub is to deal with the overlaps
    Next
End Sub

Detect Overlaps

This calls AdjustLables with an array of Labels. These labels need to be checked for overlap

Sub AdjustLabels(ByRef v() As DataLabel)
    Dim i As Long, j As Long

    For i = LBound(v) To UBound(v) - 1
    For j = LBound(v) + 1 To UBound(v)
        If v(i).Left <= v(j).Left Then
            If v(i).Top <= v(j).Top Then
                If (v(j).Top - v(i).Top) < v(i).Height _
                And (v(j).Left - v(i).Left) < v(i).Width Then
                    ' Overlap!

                End If
            Else
                If (v(i).Top - v(j).Top) < v(j).Height _
                And (v(j).Left - v(i).Left) < v(i).Width Then
                    ' Overlap!

                End If
            End If
        Else
            If v(i).Top <= v(j).Top Then
                If (v(j).Top - v(i).Top) < v(i).Height _
                And (v(i).Left - v(j).Left) < v(j).Width Then
                    ' Overlap!

                End If
            Else
                If (v(i).Top - v(j).Top) < v(j).Height _
                And (v(i).Left - v(j).Left) < v(j).Width Then
                    ' Overlap!

                End If
            End If
        End If
    Next j, i
End Sub

Moving Labels

When an overlap is detected you need a strategy that move one or both labels without creating another overlap.
There are many possibilities here, you havn'e given sufficient details to judge your requirements.

Note about Excel

For this approach to work you need a version of Excel that has DataLabel.Width and DataLabel.Height properties. Version 2003 SP2 (and, presumably, earlier) does not.

Answer 2

This macro will prevent overlapping labels on 2 line charts when data source is listed in two adjacent columns.

Attribute VB_Name = "DataLabel_Location"
Option Explicit


Sub DataLabel_Location()
'
'
' *******move data label above or below line graph depending or other line graphs in same chart***********

Dim Start As Integer, ColStart As String, ColStart1 As String
Dim RowStart As Integer, Num As Integer, x As Integer, Cell As Integer, RowEnd As Integer

Dim Chart As String, Value1 As Single, String1 As String


Dim Mycolumn As Integer
Dim Ans As String
Dim ChartNum As Integer



   Ans = MsgBox("Was first data point selected?", vbYesNo)
    Select Case Ans
    Case vbNo
    MsgBox "Select first data pt then restart macro."
    Exit Sub

    End Select

     On Error Resume Next


ChartNum = InputBox("Please enter Chart #")
    Chart = "Chart " & ChartNum
ActiveSheet.Select

ActiveCell.Select


RowStart = Selection.row
ColStart = Selection.Column
ColStart1 = ColStart + 1
ColStart = ColNumToLet(Selection.Column)
RowEnd = ActiveCell.End(xlDown).row
ColStart1 = ColNumToLet(ActiveCell.Offset(0, 1).Column)

Num = RowEnd - RowStart + 1


With ThisWorkbook.ActiveSheet.Select
    ActiveSheet.ChartObjects(Chart).Activate
    ActiveChart.SeriesCollection(1).ApplyDataLabels
    ActiveChart.SeriesCollection(2).ApplyDataLabels
End With

    For x = 1 To Num

           Value1 = Range(ColStart & RowStart).Value
           String1 = Range(ColStart1 & RowStart).Value


        If Value1 = 0 Then
            ActiveSheet.ChartObjects(Chart).Activate
            ActiveChart.SeriesCollection(1).DataLabels(x).Select
            Selection.Delete
        End If

        If String1 = 0 Then
            ActiveSheet.ChartObjects(Chart).Activate
            ActiveChart.SeriesCollection(2).DataLabels(x).Select
            Selection.Delete
        End If


        If Value1 <= String1 Then



            ActiveSheet.ChartObjects("Chart").Activate

            ActiveChart.SeriesCollection(1).DataLabels(x).Select
            Selection.Position = xlLabelPositionBelow
            ActiveChart.SeriesCollection(2).DataLabels(x).Select
            Selection.Position = xlLabelPositionAbove




        Else
            ActiveSheet.ChartObjects("Chart").Activate
            ActiveChart.SeriesCollection(1).DataLabels(x).Select
            Selection.Position = xlLabelPositionAbove
            ActiveChart.SeriesCollection(2).DataLabels(x).Select
            Selection.Position = xlLabelPositionBelow

        End If
            RowStart = RowStart + 1
    Next x

End Sub

'
' convert column # to column letters
'
Function ColNumToLet(Mycolumn As Integer) As String
  If Mycolumn > 26 Then
    ColNumToLet = Chr(Int((Mycolumn - 1) / 26) + 64) & Chr(((Mycolumn - 1) Mod 26) + 65)
  Else
    ColNumToLet = Chr(Mycolumn + 64)
  End If
End Function