Data labels on the outside end of error bars without overlapping?

[Crucis]

Dear all,

I have a recurrent problem when making column/bar charts with error bars and data labels. Whenever I add data labels to the outside end, these labels will always overlap the error bars (please see image). Is there any automatic solution to position the data labels on the outside end of the error bars (instead of the column end)? Dragging each data label manually is annoying and time consuming when dealing with a lot of data.

Thanks in advance for your help!

 

[pbornemeier]

Modified for use with Table References

Option Explicit

Sub EditAndMoveDataLabelOnGraphWithTableRefs()

    Dim cht As Chart
    Dim ser As Series
    Dim rngSeries As Range
    Dim sFormula As String
    Dim rngDL As Range
    Dim rngHE As Range
    Dim pt As Point
    Dim sngX As Single
    Dim sngY As Single
    Dim sngColumnHeight As Single
    Dim sngScalingFactor As Single
    Dim lMaxPoint As Long
    Dim aryValues As Variant
    Dim aryDataLabels As Variant
    Dim aryErrors As Variant
    Dim sngMaxValue As Single
    Dim lPointIndex As Long
    Dim lPointCount As Long
    Dim sngValue As Single
    Dim lSerIndex As Long
    Dim lo As ListObject
    Dim aryTableNames As Variant
    Dim lTblIndex As Long
    Dim arySeries As Variant
    
    aryTableNames = Array("tblMyData_TotalPCI", "tblMyData_EmergentPCI", "tblMyData_NonEmergentPCI")
    arySeries = Array("Total PCI", "Emergent PCI", "Non-Emergent PCI")
    
    If TypeName(ActiveSheet) = "Chart" Then
         Set cht = ActiveChart
    Else
        If ActiveSheet.ChartObjects.Count = 0 Then
            MsgBox "No Charts on active sheet.  Exiting"
            GoTo End_Sub
        End If
        Set cht = ActiveSheet.ChartObjects(1).Chart     'If more than one chart on the activesheet
    End If
    
    For lTblIndex = 0 To 2
    
        Set ser = cht.SeriesCollection(arySeries(lTblIndex))
        
        Set rngSeries = Range(aryTableNames(lTblIndex) & "[Plot Value]")    'Get range of Y-Axis cells
        Set rngDL = Range(aryTableNames(lTblIndex) & "[Data Label]")        'Get range of desired Data Labels
        Set rngHE = Range(aryTableNames(lTblIndex) & "[High Error Bar]")    'Get range of High Error values
        
        With Worksheets(Range(aryTableNames(lTblIndex)).Worksheet.Name) 'Worksheet holding table
            aryValues = .Range(rngSeries.Address)            'Get values for each point
            aryDataLabels = .Range(rngDL.Address)            'Get desired Data Labels for each point
            aryErrors = .Range(rngHE.Address)                'Get high error values for each point
        End With
        
        'Reset the data labels to their original position before applying correction
        If ser.HasDataLabels Then ser.HasDataLabels = False
        ser.HasDataLabels = True
        ser.DataLabels.Position = xlLabelPositionOutsideEnd
        
        'Calculate Offset Scaling Factor based on tallest column
        sngMaxValue = 0
        lPointCount = ser.Points.Count
        For lPointIndex = 1 To lPointCount
            sngValue = aryValues(lPointIndex, 1)
            If sngValue > sngMaxValue Then
                sngMaxValue = sngValue
                lMaxPoint = lPointIndex
            End If
        Next
        sngColumnHeight = ser.Points(lMaxPoint).Height
        sngScalingFactor = sngColumnHeight / sngMaxValue
        
        'Move & Edit Labels
        For lPointIndex = 1 To lPointCount
            With ser.Points(lPointIndex).DataLabel
                If Not IsEmpty(aryErrors(lPointIndex, 1)) Then
                    'There is a High Error, so move Data Label Text Box
                    .Top = .Top - (aryErrors(lPointIndex, 1) * sngScalingFactor) + 3
                End If
                'Update Data Label Text box whether it was moved or not
                .Text = aryDataLabels(lPointIndex, 1)
            End With
        Next
            
    Next
    
End_Sub:
    
End Sub

 

[Huey72]

This works perfectly Phil...thanks so much! One last question - is there a way to create the table name array dynamically? Something along the lines of: for each listobject in activesheet.listobjects, build the array of table names?
I imagine I'll run into the same issue with other charts before I'm done with this utility - but at that point, the table names will be different - this would help me re-use the code when the table names change on different sheets.

 

[Huey72]

Hi Phil - I've attempted to build the list of table names dynamically myself...this approach seems to be working, but may not be the most efficient...here's what I've added...what do you think?

Dim myString As Variant
Dim Tbl As ListObject


'Loop through table in the worksheet and create a delimited string of table names
For Each Tbl In ActiveSheet.ListObjects
myString = myString & ", " & Tbl.Name
Next Tbl


'Remove first delimiter from string (, )
myString = Right(myString, Len(myString) - 2)

aryTableNames = Split(myString, ",") ' previously was aryTableNames = Array("tblMyData_TotalPCI", "tblMyData_EmergentPCI", "tblMyData_NonEmergentPCI")

 

[pbornemeier]

Will the 3 tables you want to plot all be on the same worksheet?
Will only those tables be on that worksheet?
Will the chart also be on that worksheet?
Does the order matter?

If the answers are yes, yes, yes, no then this would work:

Replace the code between the blue lines in my last post with the non-blue code here:

    [COLOR="#0000FF"]Dim arySeries As Variant[/COLOR]
    
    arySeries = Array("Total PCI", "Emergent PCI", "Non-Emergent PCI")
    
    If TypeName(ActiveSheet) = "Worksheet" Then
        If ActiveSheet.ListObjects.Count <> 3 Then
            MsgBox "You must have 3 tables on the activeworksheet.  Exiting"
        End If
        aryTableNames = Array(ActiveSheet.ListObjects(1), ActiveSheet.ListObjects(2), ActiveSheet.ListObjects(3))
        Set cht = ActiveSheet.ChartObjects(1).Chart     'If more than one chart on the activesheet
    Else
        MsgBox "Start this code with the workhseet containing the listobjects for the chart as the activesheet.  Exiting"
        GoTo End_Sub
    End If
    
    [COLOR="#0000FF"]For lTblIndex = 0 To 2[/COLOR]

If the answers don't match, then something else could probably be done, but you would have to provide those details.

Will the series name also change?
If your table name contains the series name then you could probably extract the series name from it
With a name like tblMyData_Total_PCI_
You could extract the text between the first and last underscores then change any remaining underscores to spaces.

Do you have the code to assign the various columns in the table to the desired parts of the graph?

This is code to assign a range the error bars for a particular series

Sub AddErrorBarsToColumnChart()
    
    Dim rngEBPlus As Range
    Dim rngEBMinus As Range
    
    Set rngEBPlus = Range("CN3:CN40")
    Set rngEBMinus = Range("CM3:CM40")
    
    ActiveChart.FullSeriesCollection(1).ErrorBar Direction:=xlY, Include:= _
        xlBoth, Type:=xlErrorBarTypeCustom, Amount:=rngEBPlus, MinusValues:=rngEBMinus
    Range("X9").Select
    
    ActiveChart.SetElement (msoElementErrorBarNone)
    ActiveChart.FullSeriesCollection(1).HasErrorBars = True

End Sub

 

[Huey72]

Many thanks Phil...the answers are yes, yes, yes, no...your first block works like charm. Thanks a million!

 

[pbornemeier]

Glad to help - thanks for the feedback.

 

[amedicalenthusiast]

I added a bit of code to allow editing of the numeric data label value. If it would be useful for your application it would also be possible to add code to change the fill color and/or border color of individual data labels or data bars. Change "False" to "True" in the first line of the last "paragraph" in the code to see a sample of coloring the data label.

Option Explicit

Sub Test_MoveDataLabelsOnActiveChart()

    MoveDataLabelsOnSpecifiedSeriesInActiveChart 1, 0, -10, "CustomColumn", True, "OVERwRITe"

End Sub

Sub MoveDataLabelsOnSpecifiedSeriesInActiveChart(lSeries As Long, sngX As Single, sngY As Single, _
    Optional sTypeErrorBar As String, Optional bReset As Boolean, Optional sEditDataLabel As String)
    'For the series lSeries on the active chart, if data labels are present, move them as specified
   
    'The data for the column chart must be arranged as follows:
    '1st Column:    Data Point Name
    '2nd Column:    Data Point Value
    '3rd Column:    Data Point Error Bar Value (will provide odd results if negative)
    '4th Column:    Data Label Modifier Value
   
    'Positive sngX value moves label to right
    'Positive sngY value moves label down
    'sTypeErrorBar (only the following are implemented)
    '               "FixedValueColumn"  uses sngX & sngY for offset 'Can be used for column or bar charts.
    '               "CustomColumn"      uses column to right of values for vertical offset.  Designed for Column Charts Only
    'If bReset is true the labels will be set to their original position before applying the specified correction.
    'sEditDataLabel if one of the following options is specified the data label will be modified as follows:
    '               "AppendWithSpace"   - Space & Data Label Modifier Value will be added after the current Data Label Value
    '               "AppendWithCR"      - Data Label Modifier Value will be added under the current Data Label Value
    '               "Overwrite"         - Data Label Value will be replaced with the Data Label Modifier Value
   
    Dim lChartSeriesCount As Long
    Dim pt As Point
    Dim sngOffset As Single
    Dim sngMultiplier As Single
    Dim sValuesRange As String
    Dim aryErrors As Variant
    Dim aryValues As Variant
    Dim aryDataLabels As Variant
    Dim lPointIndex As Long
    Dim lPointCount As Long
    Dim sngScalingFactor As Single
    Dim sngMaxValue As Single
    Dim sngValue As Single
    Dim lMaxPoint As Long
    Dim sngColumnHeight As Single
   
    If ActiveChart Is Nothing Then _
        MsgBox "Select a chart and try again.", , "Select Chart": GoTo End_Sub
    On Error Resume Next
    lChartSeriesCount = ActiveChart.SeriesCollection.Count
    If Err.Number <> 0 Then _
        MsgBox "No series in selected chart.", , "Add Series to Chart": GoTo End_Sub
    On Error GoTo 0
    If ActiveChart.SeriesCollection.Count < lSeries Then _
        MsgBox "Chart has " & lChartSeriesCount & " series.", , "Specified Series Does Not Exist": GoTo End_Sub
    If Not ActiveChart.SeriesCollection(lSeries).HasDataLabels Then
        MsgBox "The specified series does not have data labels.", , "Specified Series Does Not Have Labels": GoTo End_Sub
    End If
   
    If bReset Then
        'Reset the data labels to their original position before applying correction
        ActiveChart.SeriesCollection(lSeries).HasDataLabels = False
        ActiveChart.SeriesCollection(lSeries).HasDataLabels = True
    End If
   
    lPointCount = ActiveChart.SeriesCollection(lSeries).Points.Count
   
    Select Case sTypeErrorBar
    Case "CustomColumn"
        sValuesRange = Split(ActiveChart.SeriesCollection(lSeries).Formula, ",")(2)
        aryErrors = Range(Split(sValuesRange, "!")(1)).Offset(0, 1)
        aryValues = Range(Split(sValuesRange, "!")(1))
        aryDataLabels = Range(Split(sValuesRange, "!")(1)).Offset(0, 2)
       
        'Calculate Offset Scaling Factor based on tallest column
        sngMaxValue = 0
        For lPointIndex = 1 To lPointCount
            sngValue = aryValues(lPointIndex, 1)
            If sngValue > sngMaxValue Then
                sngMaxValue = sngValue
                lMaxPoint = lPointIndex
            End If
        Next
        sngColumnHeight = ActiveChart.SeriesCollection(lSeries).Points(lMaxPoint).Height
        sngScalingFactor = sngColumnHeight / sngMaxValue
       
        'Move Labels
        For lPointIndex = 1 To lPointCount
            With ActiveChart.SeriesCollection(lSeries).Points(lPointIndex).DataLabel
                .Top = .Top - (aryErrors(lPointIndex, 1) * sngScalingFactor)
            End With
        Next
    Case "FixedValueColumn"
        For Each pt In ActiveChart.SeriesCollection(lSeries).Points
            With pt.DataLabel
                .Left = pt.DataLabel.Left + sngX
                .Top = pt.DataLabel.Top + sngY
            End With
        Next
    Case Else
        MsgBox "Not yet implemented"
    End Select
   
    'Edit Data Labels
    Select Case UCase(sEditDataLabel)
    Case ""
        'Do nothing
    Case "APPENDWITHSPACE"
        For lPointIndex = 1 To lPointCount
            With ActiveChart.SeriesCollection(lSeries).Points(lPointIndex).DataLabel
                .Text = .Text & " " & aryDataLabels(lPointIndex, 1)
            End With
        Next
    Case "APPENDWITHCR"
        For lPointIndex = 1 To lPointCount
            With ActiveChart.SeriesCollection(lSeries).Points(lPointIndex).DataLabel
                .Text = .Text & vbLf & aryDataLabels(lPointIndex, 1)
            End With
        Next
    Case "OVERWRITE"
        For lPointIndex = 1 To lPointCount
            With ActiveChart.SeriesCollection(lSeries).Points(lPointIndex).DataLabel
                .Text = aryDataLabels(lPointIndex, 1)
            End With
        Next
    Case Else
        MsgBox sEditDataLabel & " is not a valid option for sEditDataLabel.  Use one of the following:" & vbLf & _
            "    AppendWithSpace" & vbLf & _
            "    AppendWithCR" & vbLf & _
            "    Overwrite" & vbLf, , "Invalid Edit Data Label Option"
    End Select
   
   
    'Color Data Labels
    If False Then  'Change 2nd word in this line to True to color data labels to specified colors.
        For lPointIndex = 1 To lPointCount
            ActiveChart.SeriesCollection(lSeries).Points(lPointIndex).DataLabel.Select
            With Selection.Format.Fill
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 255, 0)
                .Transparency = 0
                .Solid
            End With
            With Selection.Format.Line
                .Visible = msoTrue
                .ForeColor.RGB = rgbRed
                .Transparency = 0
            End With
        Next
    End If
   
End_Sub:
   
End Sub

Hi @pbornemeier . Thank you very much for the codes! I am having the same problem, but with bar charts instead of column charts. I noticed that what needs to be changed is the Case "CustomColumn", but I can't seem to make things work. This is the snippet of my dataset, so I'm confused on:
1. how to refer the series as my data, error bars, and labels are not in adjacent cells, and
2. how to modify the `aryErrors` since my error bars are asymmetrical (in the real dataset)

For the `aryDataLabels`, I changed it to `aryDataLabels = Range(Split(sValuesRange, "!")(1)).Offset(0, 5)` since the labels are five cells on the right of the value, is that correct?

Any help would be much appreciated. Thanks!

 

[amedicalenthusiast]

Hi @pbornemeier . Thank you very much for the codes! I am having the same problem, but with bar charts instead of column charts. I noticed that what needs to be changed is the Case "CustomColumn", but I can't seem to make things work. This is the snippet of my dataset, so I'm confused on:
1. how to refer the series as my data, error bars, and labels are not in adjacent cells, and
2. how to modify the `aryErrors` since my error bars are asymmetrical (in the real dataset)

For the `aryDataLabels`, I changed it to `aryDataLabels = Range(Split(sValuesRange, "!")(1)).Offset(0, 5)` since the labels are five cells on the right of the value, is that correct?

Any help would be much appreciated. Thanks!

Ok I believe this should be simple, based on your codes, I changed "1DLOffset" to 5 and "1HEOffset" to 4 (value is the y-axis (bottom) and name is the x-axis (left)). However it says "Type mismatch". Am I missing something? I shouldn't be changing any other inputs, right?