VBA code to position data labels on top of the stacks in a stacked columns chart

N

NiceLittleRabbit

New Member
Joined
Sep 7, 2009
Messages
4
Hello,

While further refining my waterfall VBA code, I could not find the way to position the data labels on top of the stacks. And of course, the labels are often positioned in the stacks themselves, making them difficult to read and very ugly to watch.

Is there a way to request the labels to be on top of the stacks?

Here comes my code, in which data labels are displayed only if they are different from zero. I have a file ready to be tested, but could not find a way to attach it to this post, so if you PM me I can send it out. However, the code below is the same as the one in the worksheet.

Help on this would, as usual, be MUCH appreciated

Thank you in advance

My worksheet "Global" looks like this (some random data), starting row 3:

<table width="192" border="0" cellpadding="0" cellspacing="0"><colgroup><col style="mso-width-source:userset;mso-width-alt:3271;width:69pt" width="92"> <col style="mso-width-source:userset;mso-width-alt:1792; width:38pt" span="2" width="50"> </colgroup><tbody><tr style="height:14.4pt" height="19"> <td style="height:14.4pt;width:69pt" width="92" height="19">A</td> <td style="width:38pt" width="50" align="right">0</td> <td style="width:38pt" width="50" align="right">0</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">B</td> <td align="right">0</td> <td align="right">0</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">C</td> <td align="right">0</td> <td align="right">0</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">D</td> <td align="right">0</td> <td align="right">0</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">E</td> <td align="right">53440</td> <td align="right">48614</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">F</td> <td align="right">148629</td> <td align="right">171081</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">G</td> <td align="right">3540</td> <td align="right">4075</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">H</td> <td align="right">48139</td> <td align="right">39893</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">I</td> <td align="right">4525</td> <td align="right">5795</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">J</td> <td align="right">6773</td> <td align="right">3077</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">K</td> <td align="right">6319</td> <td align="right">2471</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">L</td> <td align="right">1828</td> <td align="right">674</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">M</td> <td align="right">230</td> <td align="right">433</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">N</td> <td align="right">6239</td> <td align="right">204</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">O</td> <td align="right">0</td> <td align="right">1360</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">P</td> <td align="right">0</td> <td align="right">382</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">Q</td> <td align="right">24451</td> <td align="right">0</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">R</td> <td align="right">423</td> <td align="right">1465</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">S</td> <td align="right">1004</td> <td align="right">5250</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">T</td> <td align="right">750</td> <td align="right">6024</td> </tr> <tr style="height:14.4pt" height="19"> <td style="height:14.4pt" height="19">U</td> <td align="right">288</td> <td align="right">33763</td> </tr> </tbody></table>

Code: 
Public Sub DrawWaterfallChart()

Dim SheetName As String
Dim Data1Col As Integer, Data2Col As Integer, LabelsCol As Integer
Dim FirstRow As Long, LastRow As Long

LabelsCol = 1
Data1Col = 2
Data2Col = 3
FirstRow = 3
LastRow = 23

SheetName = "Global"


Dim rng1 As Range, rng2 As Range, rnglabels As Range, rngGlobal As Range

Dim myChtObj As ChartObject
Dim iColumn As Long

Dim plus() As Double
Dim minus() As Double
Dim basement() As Double
Dim labels() As String
Dim Height As Long
Height = LastRow - FirstRow + 1
Dim Initial As Double

'Let's put the data in arrays because in the final application the data will be coming from arrays

ReDim plus(1 To Height)
ReDim minus(1 To Height)
ReDim basement(1 To Height)
ReDim labels(1 To Height)

Dim Row As Long, Col As Integer

For Row = 1 To Height
    If Sheets(SheetName).Cells(FirstRow + Row - 1, Data2Col) > Sheets(SheetName).Cells(FirstRow + Row - 1, Data1Col) Then
        plus(Row) = Sheets(SheetName).Cells(FirstRow + Row - 1, Data2Col) - Sheets(SheetName).Cells(FirstRow + Row - 1, Data1Col)
        minus(Row) = 0
    Else
        plus(Row) = 0
        minus(Row) = -Sheets(SheetName).Cells(FirstRow + Row - 1, Data2Col) + Sheets(SheetName).Cells(FirstRow + Row - 1, Data1Col)
    End If
Next Row

For Row = 1 To UBound(plus)
    If plus(Row) > 0 Then
        basement(Row) = Sheets(SheetName).Cells(FirstRow + Row - 1, Data2Col)
    Else
        basement(Row) = Sheets(SheetName).Cells(FirstRow + Row - 1, Data1Col)
    End If
    labels(Row) = Sheets(SheetName).Cells(FirstRow + Row - 1, LabelsCol)
Next Row

Set myChtObj = Sheets(SheetName).ChartObjects.Add(Left:=250, Width:=375, Top:=75, Height:=225)

Dim Invisible As Series
    
Dim Positive As Series
    
Dim Negative As Series

' Add the chart
With myChtObj.Chart
    .ChartArea.Fill.Visible = False
    .PlotArea.Format.Fill.Solid
    .PlotArea.Format.Fill.Transparency = 1
    .HasTitle = True
    .HasLegend = False
    
    .ChartTitle.Text = "My chart"
        
    .Axes(xlCategory, xlPrimary).HasTitle = True
    .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Units"
    .Axes(xlValue, xlPrimary).HasTitle = True
    .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Quantity"
    
    
    .ChartGroups(1).GapWidth = 0

    ' Make Column Stacked chart
    .ChartType = xlColumnStacked
    
    ' Add series from selected range, column by column
    Set Invisible = .SeriesCollection.NewSeries
    With Invisible
        .Values = basement
        .XValues = labels
        .Name = "Labels"
        With .Border
            .ColorIndex = 13
            .Weight = xlMedium
            .LineStyle = xlNone
        End With
        .Format.Fill.Visible = False
        .Format.Line.Transparency = 0
        .MarkerStyle = xlNone
    End With
    
    Set Positive = .SeriesCollection.NewSeries
    With Positive
        .Values = plus
        .XValues = labels
        .Name = "Plus"
        .Interior.ColorIndex = 14
    
        .HasDataLabels = False
    End With
    
    nPts = Positive.Points.Count 'save the number of points
    aVals = Positive.Values 'save all the values in array

    For Col = 1 To nPts ' loop through all points
        If aVals(Col) > 0 Then
            t = "+" & CStr(Round(aVals(Col)))
            Positive.Points(Col).HasDataLabel = True
            With Positive.Points(Col).DataLabel
                .Text = t
                ' Here I'd like to be able to request the data label to be above the stack (xlLabelPositionAbove)
                .Position = 4 'Only accepts 3 (xlLabelPositionInsideEnd) and 4 (xlLabelPositionInsideBase)
                With .Font
                    .ColorIndex = 14
                    .Size = 6
                End With
            End With
        End If
    Next Col

            
    Set Negative = .SeriesCollection.NewSeries
    With Negative
        .Values = minus
        .XValues = labels
        .Name = "Minus"
        .Interior.ColorIndex = 18
    End With
    
    nPts = Negative.Points.Count 'save the number of points
    aVals = Negative.Values 'save all the values in array

    For Col = 1 To nPts ' loop through all points
        If aVals(Col) > 0 Then
            t = "-" & CStr(Round(aVals(Col)))
            Negative.Points(Col).HasDataLabel = True
            With Negative.Points(Col).DataLabel
                .Text = t
                ' Here I'd like to be able to request the data label to be above the stack (xlLabelPositionAbove)
                .Position = 4 'Only accepts 3 (xlLabelPositionInsideEnd) and 4 (xlLabelPositionInsideBase)
                With .Font
                    .ColorIndex = 18
                    .Size = 6
                End With
            End With
        End If
    Next Col
        
End With

End Sub
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
Sort by date Sort by votes
Once again, problem solved thanks to Andy Pope, from http://www.excelforum.com

I upload the macro (not very nice code, but you can personalize if you want) to draw waterfall charts with data labels on top of the stacks.

Enjoy!!

The code:

Code: 
Public Sub Draw()

Dim SheetName As String
Dim Data1Col As Integer, Data2Col As Integer, LabelsCol As Integer
Dim FirstRow As Long, LastRow As Long

LabelsCol = 1
Data1Col = 2
Data2Col = 3
FirstRow = 3
LastRow = 23

SheetName = "Global"

DrawWaterfallChart SheetName, Data1Col, Data2Col, LabelsCol, FirstRow, LastRow

End Sub
___________________________________________________
Public Sub DrawWaterfallChart(SheetName As String, Data1Col As Integer, Data2Col As Integer, LabelsCol As Integer, FirstRow As Long, LastRow As Long)

Dim rng1 As Range, rng2 As Range, rnglabels As Range, rngGlobal As Range

Dim myChtObj As ChartObject
Dim iColumn As Long

Dim plus() As Double
Dim minus() As Double
Dim basement() As Double
Dim labels() As String
Dim Height As Long
Height = LastRow - FirstRow + 1
Dim Initial As Double

'Let's put the data in arrays because in the final application the data will be coming from arrays

ReDim plus(1 To Height)
ReDim minus(1 To Height)
ReDim basement(1 To Height)
ReDim labels(1 To Height)

Dim Row As Long, Col As Integer

For Row = 1 To Height
    If Sheets(SheetName).Cells(FirstRow + Row - 1, Data2Col) > Sheets(SheetName).Cells(FirstRow + Row - 1, Data1Col) Then
        plus(Row) = Sheets(SheetName).Cells(FirstRow + Row - 1, Data2Col) - Sheets(SheetName).Cells(FirstRow + Row - 1, Data1Col)
        minus(Row) = 0
    Else
        plus(Row) = 0
        minus(Row) = -Sheets(SheetName).Cells(FirstRow + Row - 1, Data2Col) + Sheets(SheetName).Cells(FirstRow + Row - 1, Data1Col)
    End If
Next Row

For Row = 1 To UBound(plus)
    If plus(Row) > 0 Then
        basement(Row) = Sheets(SheetName).Cells(FirstRow + Row - 1, Data2Col)
    Else
        basement(Row) = Sheets(SheetName).Cells(FirstRow + Row - 1, Data1Col)
    End If
    labels(Row) = Sheets(SheetName).Cells(FirstRow + Row - 1, LabelsCol)
Next Row

Dim StringLabels() As String
ReDim StringLabels(1 To Height)

For Row = 1 To UBound(StringLabels)
    If plus(Row) > 0 Then
        StringLabels(Row) = "-" & CStr(Round(plus(Row)))
    ElseIf minus(Row) > 0 Then
        StringLabels(Row) = "+" & CStr(Round(minus(Row)))
    Else
        StringLabels(Row) = ""
    End If
Next Row

Dim LabelValues() As Double
ReDim LabelValues(1 To Height) As Double

For Row = 1 To UBound(LabelValues)
    LabelValues(Row) = basement(Row) + plus(Row) + minus(Row)
Next Row

Set myChtObj = Sheets(SheetName).ChartObjects.Add(Left:=250, Width:=375, Top:=75, Height:=225)

Dim Invisible As Series
Dim Positive As Series
Dim Negative As Series
Dim InvisibleLineLabels As Series

Dim Pts As Points
Dim Pt As Point

' Add the chart
With myChtObj.Chart
    .ChartArea.Fill.Visible = False
    .PlotArea.Format.Fill.Solid
    .PlotArea.Format.Fill.Transparency = 1
    .HasTitle = True
    .HasLegend = False
    
    .ChartTitle.Text = "My chart"
        
    .Axes(xlCategory, xlPrimary).HasTitle = True
    .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Units"
    .Axes(xlValue, xlPrimary).HasTitle = True
    .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Quantity"
    
    
    .ChartGroups(1).GapWidth = 0

    ' Make Column Stacked chart
    .ChartType = xlColumnStacked
    
    ' Add series from selected range, column by column
    Set Invisible = .SeriesCollection.NewSeries
    With Invisible
        .Values = basement
        .XValues = labels
        .Name = "Labels"
        With .Border
            .ColorIndex = 13
            .Weight = xlMedium
            .LineStyle = xlNone
        End With
        .Format.Fill.Visible = False
        .Format.Line.Transparency = 0
        .MarkerStyle = xlNone
        .HasDataLabels = False
    End With
    
    Set Positive = .SeriesCollection.NewSeries
    With Positive
        .Values = plus
        .XValues = labels
        .Name = "Plus"
        .Interior.ColorIndex = 14
        .HasDataLabels = False
    End With
    
    Set Negative = .SeriesCollection.NewSeries
    With Negative
        .Values = minus
        .XValues = labels
        .Name = "Minus"
        .Interior.ColorIndex = 18
        .HasDataLabels = False
    End With

    
    Set InvisibleLineLabels = .SeriesCollection.NewSeries
    With InvisibleLineLabels
        .Type = xlLine
        .Values = LabelValues
        .XValues = labels
        .Name = "Labels"
        With .Border
            .LineStyle = xlNone
        End With
        .Format.Fill.Visible = False
        .MarkerStyle = xlNone
        .HasDataLabels = True
    End With
    
    Set Pts = InvisibleLineLabels.Points
    
    Row = 0
    For Each Pt In Pts
        Row = Row + 1
        Pt.DataLabel.Text = StringLabels(Row)
        Pt.DataLabel.Font.Bold = False
        Pt.DataLabel.Font.Size = 6
        Pt.DataLabel.Position = xlLabelPositionAbove
    Next Pt
        
End With

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
VBA Function to Paste Table into Outlook Email Resulting in HTML language in Email
Replies
8
Views
616
smozgur
smozgur
S
  • Question Question
VBA code for adding new group of columns with 3 condictions from 2 dictionary and 1 array Then fill in data from value from original columns
Replies
1
Views
122
sijpie
sijpie
E
  • Question Question
VBA code clean up
Replies
9
Views
573
mumps
mumps
D
  • Question Question
Problems Encountered When Generating VBA Excel Charts with 15-Minute Interval Data.
Replies
0
Views
364
dilshod_k
D
J
  • Question Question
Moving duplicate Column Data to individual rows in VBA
Replies
6
Views
360
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,224,514
Messages
6,179,219
Members
452,895
Latest member
BILLING GUY

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top