VBA Chart Legend

I have the following code to standardize the colors on 3 pie charts, with this logic is it possible to create a master legend that would be to the right of the last graph that would have all of the categories even if they are not currently in any of the charts.

Sub ColorPieSlices()
    NumPoints = ActiveChart.SeriesCollection(1).Points.Count
    For x = 1 To NumPoints
        If ActiveChart.SeriesCollection(1). _
            Points(x).HasDataLabel = True Then
                SavePtLabel = ActiveChart.SeriesCollection(1) _
                    .Points(x).DataLabel.Text
        Else
            SavePtLabel = ""
        End If
        ActiveChart.SeriesCollection(1).Points(x).ApplyDataLabels Type:= _
            xlDataLabelsShowLabel, AutoText:=True
        ThisPt = ActiveChart.SeriesCollection(1).Points(x).DataLabel.Text
        Select Case ThisPt
            Case "100% Complete"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 5
             Case "Force of Nature"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 3
            Case "Agreement"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 7
            Case "Customs"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 22
             Case "Products"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 26
             Case "Registration"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 38
            Case "In-Budget"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 4
            Case "Lld- Agreement"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 13
             Case "Lld- Approvals"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 18
            Case "Lld- Contractor"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 29
            Case "Manufacturing Delay"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 46
            Case "Take-off Delay"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 45
            Case "Take-off Error"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 40
            Case "Transportation Delay"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 53
            Case "Partner- Approvals"
            Case Else
                ' Add code here to handle an unexpected label
        End Select
        ' Return the label to it's original pre-macro state
        ActiveChart.SeriesCollection(1). _
            Points(x).DataLabel.Text = SavePtLabel
    Next x
End Sub

Open in new window

jmac001Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

byundtMechanical EngineerCommented:
In Excel 2013, the legend of a pie chart includes all the different category values, including ones with a value of blank, 0, #N/A, empty string or random text.

Which version of Excel are you using?

Could you please post a sample file?
0
byundtMechanical EngineerCommented:
The following macro is working in my Excel 2013 sample workbook. It assumes that the rightmost chart is named "Chart 4". As written, the macro calls your ColorPieSlices sub 3 times, deletes the legend from the rightmost chart, then reapplies it.
Sub Charter()
Dim oCht As ChartObject
Dim cel As Range
Application.ScreenUpdating = False
Set cel = ActiveCell
For Each oCht In ActiveSheet.ChartObjects
    oCht.Select
    ColorPieSlices
Next
With ActiveSheet.ChartObjects("Chart 4")  'Change name to match your workbook
    On Error Resume Next
    .Chart.Legend.Delete
    On Error GoTo 0
    .Chart.HasLegend = True
    .Chart.Legend.Top = 10
    .Chart.Legend.Height = .Chart.ChartArea.Height
End With
cel.Select
End Sub

Open in new window

I don't believe it matters, but I modified your ColorPieSlices sub by adding Dim statements to it.
Sub ColorPieSlices()
Dim NumPoints As Long, x As Long
Dim SavePtLabel As String, ThisPt As String
    NumPoints = ActiveChart.SeriesCollection(1).Points.Count
    For x = 1 To NumPoints
        If ActiveChart.SeriesCollection(1). _
            Points(x).HasDataLabel = True Then
                SavePtLabel = ActiveChart.SeriesCollection(1) _
                    .Points(x).DataLabel.Text
        Else
            SavePtLabel = ""
        End If
        ActiveChart.SeriesCollection(1).Points(x).ApplyDataLabels Type:= _
            xlDataLabelsShowLabel, AutoText:=True
        ThisPt = ActiveChart.SeriesCollection(1).Points(x).DataLabel.Text
        Select Case ThisPt
            Case "100% Complete"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 5
             Case "Force of Nature"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 3
            Case "Agreement"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 7
            Case "Customs"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 22
             Case "Products"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 26
             Case "Registration"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 38
            Case "In-Budget"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 4
            Case "Lld- Agreement"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 13
             Case "Lld- Approvals"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 18
            Case "Lld- Contractor"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 29
            Case "Manufacturing Delay"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 46
            Case "Take-off Delay"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 45
            Case "Take-off Error"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 40
            Case "Transportation Delay"
                ActiveChart.SeriesCollection(1). _
                    Points(x).Interior.ColorIndex = 53
            Case "Partner- Approvals"
            Case Else
                ' Add code here to handle an unexpected label
        End Select
        ' Return the label to it's original pre-macro state
        ActiveChart.SeriesCollection(1). _
            Points(x).DataLabel.Text = SavePtLabel
    Next x
End Sub

Open in new window

PieChartLegendsQ28241173.xlsm
0
jmac001Author Commented:
Hi I am using 2010.  Attached is a sample file.   Is it possible to create a key/legend separate from the graph? Maybe startiing in column X of the attachment.
EE-Pie-Legend.xlsm
0
Become a CompTIA Certified Healthcare IT Tech

This course will help prep you to earn the CompTIA Healthcare IT Technician certification showing that you have the knowledge and skills needed to succeed in installing, managing, and troubleshooting IT systems in medical and clinical settings.

byundtMechanical EngineerCommented:
The macro below shows two different ways of creating a Legend starting in cells X20. The first method draws the labels and colors from Chart 3. The second method draws the labels and colors from arrays that store the values from your latest sub ColorPieSlices. I used a Boolean variable and If block to choose one or the other method.
Sub LegendMaker()
Dim ws As Worksheet
Dim cht As Chart
Dim ser As Series
Dim shp As Shape
Dim i As Long, n As Long, lngRGB As Long
Dim bChart3 As Boolean
Dim Labels As Variant, Colors As Variant
Dim cel As Range, rgLegend As Range
Application.ScreenUpdating = False
Labels = Array("100% Complete", "Force of Nature", "BRD- Agreement", "BRD- Customs", "BRD- Product", "BRD- Registration", "In-Budget", _
    "LLD- Agreement", "LLD- Approvals", "LLD- Contractor", "LLD- Go", "LLD- Possession", "M- Manufacturing Delay", "M- Take-off Delay", _
    "M- Take-off Error", "M- Transportation Delay", "PRT- Approvals", "PRT- Building Permits", "PRT- Contractor", "PRT- Customs", _
    "PRT- Operations", "PRT- Parts", "PRT- Registration", "PRT- Site Info", "Political", "SDC- Approvals", "SDC- Contractor", _
    "SDC- DD", "SDC- PM", "SDC- SD")
Colors = Array(5, 3, 7, 22, 26, 38, 4, 13, 18, 29, 39, 21, 46, 45, 40, 53, 5, 8, 11, 23, 33, 37, 41, 49, 30, 10, 12, 43, 50, 31)
Set ws = ActiveSheet
Set rgLegend = ws.Range("X20")      'Put the legend starting in this cell
bChart3 = False                     'If True, then use Chart 3 as source for Legend. If False, then use Labels and Colors arrays.

rgLegend.Value = "Legend"
rgLegend.Font.Bold = True
rgLegend.Font.Size = 14
    
    'Clear existing legend
On Error Resume Next
Set cel = rgLegend.Offset(1, 0)
Do Until cel = ""
    cel.ClearContents
    ws.Shapes("shp" & cel.Address(False, False)).Delete
    Set cel = cel.Offset(1, 0)
Loop
On Error GoTo 0

If bChart3 Then       'Create new legend from Chart 3
    Set cht = ws.ChartObjects("Chart 3").Chart
    Set ser = cht.SeriesCollection(1)
    n = ser.Points.Count
    For i = 1 To n
        With rgLegend.Offset(i, 0)
            .Value = ser.XValues(i)
            .IndentLevel = 2
            .Font.Bold = False
            .Font.Size = 11
            Set shp = ws.Shapes.AddShape(msoShapeRectangle, .Left, .Top + 3, 12, 12)
            With shp
                .Fill.ForeColor.RGB = ser.Points(i).Format.Fill.ForeColor.RGB
                .Line.Visible = msoFalse
                .Name = "shp" & rgLegend.Offset(i, 0).Address(False, False)
            End With
        End With
    Next

Else                    'Create new legend from Labels and Colors arrays
    n = UBound(Labels)
    For i = 0 To n
        With rgLegend.Offset(i + 1, 0)
            .Value = Labels(i)
            .IndentLevel = 2
            .Interior.ColorIndex = Colors(i)
            .Font.Bold = False
            .Font.Size = 11
            lngRGB = .Interior.Color
            .Interior.ColorIndex = xlNone
            Set shp = ws.Shapes.AddShape(msoShapeRectangle, .Left, .Top + 3, 12, 12)
            With shp
                .Fill.ForeColor.RGB = lngRGB
                .Line.Visible = msoFalse
                .Name = "shp" & rgLegend.Offset(i, 0).Address(False, False)
            End With
        End With
    Next
End If
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
jmac001Author Commented:
Fantastic this is exactly what I was looking for.
0
byundtMechanical EngineerCommented:
If it were my workbook, I'd put the legend text and colors in a table in a worksheet table (either a named range or a named Table). The macro would then reference that data to create the Legend, starting in a user-selected cell. Doing so would make the macro easily able to adapt to changing situations.

Brad
0
jmac001Author Commented:
I do have a worksheet with all of the codes on it and I also included the index number for the colors is that what you are referring to?
0
byundtMechanical EngineerCommented:
Exactly.

If you post a workbook that has that worksheet in it, I'll modify my code to use that data.

Brad
0
jmac001Author Commented:
Here you go thanks
Reason-Codes-EE-2013.09.19.xlsx
0
byundtMechanical EngineerCommented:
I moved the Reason Codes worksheet into the Pie Legend workbook, then used the Insert...Table menu item to turn the Reason Codes table into an Excel 2007 and later Table. Column 2 of that table is the label text and column 4 is the color codes.

Using that table instead of the long Select Case allowed me to greatly shorten the ColorPieSlices sub. And because the data is in a table, you can edit it on the worksheet, then rerun your code and all the changes will be taken into account automatically.
Sub LegendMaker()
Dim ws As Worksheet
Dim cht As Chart
Dim ser As Series
Dim shp As Shape
Dim i As Long, n As Long, lngRGB As Long
Dim bChart3 As Boolean
Dim Labels As Variant, Colors As Variant
Dim cel As Range, rgLegend As Range, tbReasonCodes As Range
On Error Resume Next
For Each ws In ActiveWorkbook.Worksheets
    Set tbReasonCodes = ws.ListObjects("tbReasonCodes").DataBodyRange
    If Not tbReasonCodes Is Nothing Then Exit For
Next

Application.ScreenUpdating = False
Set ws = ActiveSheet
Set rgLegend = Application.InputBox("Please select the cell where you want the Legend header label." & vbLf _
    & "The legend entries will go in the subsequent rows.", Type:=8)      'Put the legend starting in this cell
On Error GoTo 0
If rgLegend Is Nothing Then Exit Sub
If tbReasonCodes Is Nothing Then
    MsgBox "Couldn't find table for reason codes", vbOKOnly
    Exit Sub
End If

Labels = tbReasonCodes.Columns(2).Value
Colors = tbReasonCodes.Columns(4).Value
rgLegend.Value = "Legend"
rgLegend.Font.Bold = True
rgLegend.Font.Size = 14
    
    'Clear existing legend
On Error Resume Next
Set cel = rgLegend.Offset(1, 0)
Do Until cel = ""
    cel.ClearContents
    ws.Shapes("shp" & cel.Address(False, False)).Delete
    Set cel = cel.Offset(1, 0)
Loop
On Error GoTo 0

n = UBound(Labels)
For i = 1 To n
    With rgLegend.Offset(i, 0)
        .Value = Labels(i, 1)
        .IndentLevel = 2
        .Interior.ColorIndex = Colors(i, 1)
        .Font.Bold = False
        .Font.Size = 11
        lngRGB = .Interior.Color
        .Interior.ColorIndex = xlNone
        Set shp = ws.Shapes.AddShape(msoShapeRectangle, .Left, .Top + 3, 12, 12)
        With shp
            .Fill.ForeColor.RGB = lngRGB
            .Line.Visible = msoFalse
            .Name = "shp" & rgLegend.Offset(i, 0).Address(False, False)
        End With
    End With
Next
End Sub

Sub ColorPieSlices()
Dim NumPoints As Long, x As Long
Dim SavePtLabel As String, ThisPt As String
Dim ws As Worksheet
Dim tbReasonCodes As Range
Dim Colors As Variant, Labels As Variant, v As Variant
Dim pt As Point

On Error Resume Next
For Each ws In ActiveWorkbook.Worksheets
    Set tbReasonCodes = ws.ListObjects("tbReasonCodes").DataBodyRange
    If Not tbReasonCodes Is Nothing Then Exit For
Next
On Error GoTo 0
If tbReasonCodes Is Nothing Then
    MsgBox "Couldn't find table for reason codes", vbOKOnly
    Exit Sub
End If

Labels = tbReasonCodes.Columns(2).Value
Colors = tbReasonCodes.Columns(4).Value
NumPoints = ActiveChart.SeriesCollection(1).Points.Count

For x = 1 To NumPoints
    Set pt = ActiveChart.SeriesCollection(1).Points(x)
    SavePtLabel = ""
    If pt.HasDataLabel = True Then SavePtLabel = pt.DataLabel.Text
    pt.ApplyDataLabels Type:=xlDataLabelsShowLabel, AutoText:=True
    ThisPt = pt.DataLabel.Text
    Set v = Nothing
    On Error Resume Next
    v = Application.Match(ThisPt, Labels, 0)
    On Error GoTo 0
    If Not IsError(v) Then
        pt.Interior.ColorIndex = Colors(v, 1)
    End If
    pt.DataLabel.Text = SavePtLabel
Next x
End Sub

Open in new window

EE-Pie-LegendQ28241173.xlsm
0
jmac001Author Commented:
Again thank you so much.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.