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:
31956
Another Example of error:
31957
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
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:
31956
Another Example of error:
31957
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