Auto Standarize Line Chart Label: Reduce Label Distance, Balance Overlapping Label

**yurble_vn** · 04-27-2025, 02:58 AM

Hi,

I write below codes to standardize line chart labels in PowerPoint. It works most of the time, but not consistent.
- If I run this codes on one or two slides, it works perfectly.
- If I run these codes on PowerPoint more than 3 slides, it started to not perform consistently. Out of 10 times, 5 run normally, 5 make mistake from 3rd slides onward.

So, it is not about the Chart, it is more about the code behave not consistently. More slides, less consistent....

I am a armature in VBA. just try to combine these code from google. Hope receive your feedback....

many thanks in advance
------------------------------
Intention Explanation:
Step 1: Reset the line chart label:
- Reset the Y-Axis Min-Max base on the value of the lines; keep a margin on ton and bottom
- Change color and font size of Label
- Check the original position (Above or Below) of the label and reset it.

Step 2: Standardize Line Chart Line
- Reduce 7 points space between the label and line based on the Label position . if the label stay at the very top of the chart, reduce based on the maximum space avaiable.
- For data point #4, add series name to Label, and position it to the left of the chart.

Step 3: Balance label to avoid overlapping.
- For each series in chart, go by each data point, compare the data point label Top Position which Top position of other labels of the same data point in other series. If two labels is overlapping. Then move the label up if it has higher value, and move it down if have lower value.
- Repeat this step on the same chart 5 times.

My Expected Result:
Example 1.jpg

Another Example of error:
Example 2.jpg

Calling Sub:

Sub Chart_Format___1_Reset_LineChart_Label()
    Dim oPres       As Presentation
    Dim oSlide      As Slide
    Dim oShape      As Shape
    Dim myChart     As PowerPoint.Chart
    Dim answer      As Integer
    
    answer = MsgBox("This Macro will reset all chart label, color And font size (8)" _
           & vbCrLf & "Apply online For line chart" _
           & vbCrLf & "DOES Not WORK On GROUPED CHARTS" & vbCrLf & "BACKUP FILE BEFORE RUNNING." & vbCrLf & "Continue?" _
             , vbQuestion + vbYesNo + vbDefaultButton2, "WARNING")
    
    If answer = vbNo Then
        GoTo ErrorHandler
    End If
    
    ' Get the active presentation
    Set oPres = ActivePresentation
    
    ' Loop through each slide
    
    For Each oSlide In oPres.Slides
        ' Loop through each shape on the slide
        
        For Each oShape In oSlide.Shapes
            If oShape.HasChart Then
                Set myChart = oShape.Chart
                
                Reset_ChartLabel myChart
                Auto_Min_Max_Y_Axis myChart, 15
                
            End If
            
        Next oShape
    Next oSlide
ErrorHandler:                     MsgBox "Finish!"
End Sub


Sub Chart_Format___2_Standardize_LineChart_Label()
    Dim oPres       As Presentation
    Dim oSlide      As Slide
    Dim oShape      As Shape
    Dim myChart     As PowerPoint.Chart
    Dim answer      As Integer
    
    answer = MsgBox("This Macro will reduce 7 points from Chart Label To Line" _
           & vbCrLf & "Apply online For line chart" _
           & vbCrLf & "DOES Not WORK On GROUPED CHARTS" & vbCrLf & "BACKUP FILE BEFORE RUNNING." & vbCrLf & "Continue?" _
             , vbQuestion + vbYesNo + vbDefaultButton2, "WARNING")
    
    If answer = vbNo Then
        GoTo ErrorHandler
    End If
    
    ' Get the active presentation
    Set oPres = ActivePresentation
    
    ' Loop through each slide
    
    For Each oSlide In oPres.Slides
        ' Loop through each shape on the slide
        
        For Each oShape In oSlide.Shapes
            If oShape.HasChart Then
                Set myChart = oShape.Chart
                Reduce_ChartLabelSpace myChart, 7
                Add_SeriesName_Label myChart, 4, xlLabelPositionLeft
                
            End If
        Next oShape
    Next oSlide
ErrorHandler:                     MsgBox "Finish!"
End Sub


Sub Chart_Format___3_Balance_LineChart_Label()
    Dim oPres       As Presentation
    Dim oSlide      As Slide
    Dim oShape      As Shape
    Dim myChart     As PowerPoint.Chart
    Dim answer      As Integer
    
    answer = MsgBox("This Macro will reduce 7 points from Chart Label To Line" _
           & vbCrLf & "Apply online For line chart" _
           & vbCrLf & "DOES Not WORK On GROUPED CHARTS" & vbCrLf & "BACKUP FILE BEFORE RUNNING." & vbCrLf & "Continue?" _
             , vbQuestion + vbYesNo + vbDefaultButton2, "WARNING")
    
    If answer = vbNo Then
        GoTo ErrorHandler
    End If
    
    ' Get the active presentation
    Set oPres = ActivePresentation
    
    ' Loop through each slide
    
    For Each oSlide In oPres.Slides
        ' Loop through each shape on the slide
        
        For Each oShape In oSlide.Shapes
            If oShape.HasChart Then
                Set myChart = oShape.Chart
                ChartLabelBalance myChart
                
            End If
        Next oShape
    Next oSlide
ErrorHandler:                     MsgBox "Finish!"
End Sub

Main Sub:

Sub Auto_Min_Max_Y_Axis(myChart As Chart, ChartMargin As Integer)
    
    Dim answer, MinY, MaxY      As Integer
    
    With myChart
        Dim nSeries As Double
        Dim MinValue As Double
        Dim MaxValue As Double
        Dim vals, x As Integer
        MinValue = 1000
        MaxValue = 0
        
        For iSeries = 1 To .SeriesCollection.Count
            With .SeriesCollection(iSeries)
                'Check if this is a Line Chart
                'MsgBox iSeries
                If .Type = xlLine Then
                    vals = .Values
                    For x = LBound(vals) To UBound(vals)
                        If vals(x) > MaxValue Then
                            MaxValue = vals(x)
                        End If
                        If vals(x) <> 0 And vals(x) < MinValue Then
                            MinValue = vals(x)
                        End If
                    Next x
                Else
                    GoTo ExitSub
                End If
            End With
        Next iSeries
        .Axes(xlValue).MinimumScale = MinValue - ChartMargin
        .Axes(xlValue).MaximumScale = MaxValue + ChartMargin
    End With
    
ExitSub:
End Sub


Sub Wait(Seconds As Double)
    Dim endtime     As Double
    endtime = DateTime.Timer + Seconds
    Do
        DoEvents
    Loop While DateTime.Timer < endtime
ExitSub:
End Sub


Sub Add_SeriesName_Label(myChart As Chart, iPoints As Long, LabelPosition As XlDataLabelPosition)
    With myChart
        Dim iSeries As Long
        For iSeries = 1 To .SeriesCollection.Count
            With .SeriesCollection(iSeries)
                'Check if this is a Line Chart
                If .Type = xlLine Then
                    With .Points(iPoints)
                        .HasDataLabel = True
                        '.HasLeaderLines = True
                        .DataLabel.ShowValue = True
                        .DataLabel.ShowSeriesName = True
                        .DataLabel.Font.Bold = False
                        .DataLabel.Position = LabelPosition
                        .DataLabel.Font.Size = 8
                        
                        DoEvents
                        DoEvents
                        
                    End With
                    
                End If
            End With
        Next iSeries
        .HasLegend = False
    End With
    
ExitSub:
End Sub


Sub Reset_ChartLabel(myChart As Chart)
    With myChart
        Dim iSeries As Long
        For iSeries = 1 To .SeriesCollection.Count
            With .SeriesCollection(iSeries)
                
                Dim iColor As Long
                iColor = .Format.Line.ForeColor.RGB
                On Error Resume Next
                Dim LabelPosition As XlDataLabelPosition
                LabelPosition = .DataLabels.Position
                On Error GoTo 0
                'Check if this is a Line Chart
                If .Type = xlLine Then
                    Dim iPoints As Long
                    For iPoints = 1 To .Points.Count
                        With .Points(iPoints)
                            If .HasDataLabel Then
                                
                                .DataLabel.Position = LabelPosition
                                .DataLabel.Font.Color = iColor
                                .DataLabel.Font.Size = 8
                                .DataLabel.Font.Bold = False
                                .DataLabel.ShowSeriesName = False
                                DoEvents
                                DoEvents
                                
                            End If
                        End With
                        
                    Next iPoints
                End If
            End With
        Next iSeries
    End With
    
ExitSub:
End Sub


Sub Reduce_ChartLabelSpace(myChart As Chart, LabelSpace As Long)
    With myChart
        Dim iSeries As Long
        
        For iSeries = 1 To .SeriesCollection.Count
            With .SeriesCollection(iSeries)
                
                On Error Resume Next
                Dim LabelPosition As XlDataLabelPosition
                LabelPosition = .DataLabels.Position
                On Error GoTo 0
                'Check if this is a Line Chart
                If .Type = xlLine Then
                    Dim iPoints As Long
                    For iPoints = 1 To .Points.Count
                        With .Points(iPoints)
                            If .HasDataLabel Then
                                Dim OldPosition As Double
                                
                                OldPosition = .DataLabel.Top
                                DataPositionTop = .Top
                                On Error Resume Next
                                If LabelPosition = 0 Then        ' Above Position
                                    If OldPosition > 3 Then
                                        .DataLabel.Top = OldPosition + LabelSpace
                                    Else
                                        .DataLabel.Top = OldPosition + 4
                                    End If
                                End If
                                On Error GoTo 0
                                If LabelPosition = 1 Then
                                    .DataLabel.Top = OldPosition - LabelSpace
                                End If
                                DoEvents
                                DoEvents
                                
                            End If
                        End With
                        
                    Next iPoints
                End If
            End With
        Next iSeries
    End With
    
ExitSub:
End Sub


Sub ChartLabelBalance(myChart As Chart)
    
    With myChart
        Dim nSeries As Long
        Dim iSeries, jSeries As Long
        Dim eLoop As Integer
        
        nSeries = .SeriesCollection.Count
        
        For eLoop = 1 To 5 ' repeat 5 times
            For iSeries = 1 To nSeries
                If .SeriesCollection(iSeries).Type <> xlLine Then ' check if this is a Line, Exit if not a Line
                    GoTo ExitSub
                End If
                Dim iPoint As Long
                For iPoint = 1 To .SeriesCollection(iSeries).Points.Count
                    For jSeries = 1 To nSeries
                        If iSeries <> jSeries Then
                            
                            iVals = .SeriesCollection(iSeries).Values
                            jVals = .SeriesCollection(jSeries).Values
                            
                            On Error Resume Next  ' to escape if the data label is #NA, empty
                            Dim iTop, jTop As Double
                            If .SeriesCollection(iSeries).Points(iPoint).HasDataLabel Then
                                iTop = .SeriesCollection(iSeries).Points(iPoint).DataLabel.Top
                            Else
                                GoTo NextJLoop
                            End If
                            
                            If .SeriesCollection(jSeries).Points(iPoint).HasDataLabel Then
                                jTop = .SeriesCollection(jSeries).Points(iPoint).DataLabel.Top
                            Else
                                GoTo NextJLoop
                            End If
                            
                            If Abs(jTop - iTop) < 7 Then
                                If iVals(iPoint) > jVals(iPoint) Then
                                    If iTop > 3 Then ' dont move label if it is at the top of the chart
                                        .SeriesCollection(iSeries).Points(iPoint).DataLabel.Top = iTop - 2
                                    End If
                                    .SeriesCollection(jSeries).Points(iPoint).DataLabel.Top = jTop + 2
                                Else
                                    .SeriesCollection(iSeries).Points(iPoint).DataLabel.Top = iTop + 2
                                    If jTop > 3 Then ' dont move label if it is at the top of the chart
                                        .SeriesCollection(jSeries).Points(iPoint).DataLabel.Top = jTop - 2
                                    End If
                                End If
                                On Error GoTo 0
                                
                            End If
                        End If
NextJLoop:
                    Next jSeries
                Next iPoint
            Next iSeries
        Next eLoop
    End With
    
ExitSub:
End Sub

**yurble_vn** · 04-27-2025, 06:27 AM

And it seems that Error happen in Step 2.

If i give enough time between each steps by clicking slide by slide manually after Step 1..., the chance of running smoothly increased....

Thread: Auto Standarize Line Chart Label: Reduce Label Distance, Balance Overlapping Label

Thread Tools

Display

Auto Standarize Line Chart Label: Reduce Label Distance, Balance Overlapping Label

Posting Permissions