Solved

Combining VBA to make pies and color slices

Posted on 2013-12-04
2
356 Views
Last Modified: 2013-12-05
I have vba that creates 3 pie charts (Sub CreatePie()) and code to change the slices ('Sub ColorPieSlices())  so that they are the same for each pie.  I would like to incorporate the two, but when I do it only changes the color on the last chart created.  How would I go about doing all three at once?  

Sub CreatePie1()

With Sheets("Scorecard (2)")
NumCharts = .ChartObjects.Count
If NumCharts > 0 Then
For i = NumCharts To 1 Step -1
.ChartObjects(i).Delete
Next i
End If
End With

Charts.Add
With ActiveChart
    .ChartType = xlPie
    .SetSourceData Source:=Sheets("RCSupport").Range("F1:H28"), PlotBy:=xlColumns
    .ChartTitle.Text = "Schedule Delay Averages # of Days/Store"
    .ShowAllFieldButtons = False
    .Legend.Delete
    .ApplyDataLabels xlDataLabelsShowValue, xlDataLabelsPercent
         With .SeriesCollection(1)
         .HasLeaderLines = False
         With .DataLabels
         .ShowCategoryName = True
         .ShowValue = True
         .ShowPercentage = True
         .Position = xlLabelPositionBestFit
         .Font.Size = 11
         .Font.ColorIndex = 2
         End With
         End With
    .Location Where:=xlLocationAsObject, Name:="Scorecard (2)"
End With

With ActiveChart.Parent
         .Top = Range("A13").Top
         .Left = Range("A13").Left
         .Height = Range("13:42").Height
         .Width = Range("A:K").Width
End With

Charts.Add
With ActiveChart
    .ChartType = xlPie
    .SetSourceData Source:=Sheets("Pivots").Range("A4:B7"), PlotBy:=xlColumns
    .ChartTitle.Text = "Stores Complete at Open"
    .ShowAllFieldButtons = False
    .Legend.Delete
    .ApplyDataLabels xlDataLabelsShowValue, xlDataLabelsPercent
         With .SeriesCollection(1)
         .HasLeaderLines = False
         With .DataLabels
         .ShowCategoryName = True
         .ShowValue = True
         .ShowPercentage = True
         .Position = xlLabelPositionBestFit
         .Font.Size = 11
         .Font.ColorIndex = 2
         End With
         End With
    .Location Where:=xlLocationAsObject, Name:="Scorecard (2)"
End With

With ActiveChart.Parent
         .Top = Range("L13").Top
         .Left = Range("L13").Left
         .Height = Range("13:42").Height
         .Width = Range("L:Q").Width
End With

Charts.Add
With ActiveChart
    .ChartType = xlPie
    .SetSourceData Source:=Sheets("Pivots").Range("F4:G9"), PlotBy:=xlColumns
    .ChartTitle.Text = "Cost Variance"
    .ShowAllFieldButtons = False
    .Legend.Delete
    .ApplyDataLabels xlDataLabelsShowValue, xlDataLabelsPercent
         With .SeriesCollection(1)
         .HasLeaderLines = False
         With .DataLabels
         .ShowCategoryName = True
         .ShowValue = True
         .ShowPercentage = True
         .Position = xlLabelPositionBestFit
         .Font.Size = 11
         .Font.ColorIndex = 2
         End With
         End With
    .Location Where:=xlLocationAsObject, Name:="Scorecard (2)"
End With

With ActiveChart.Parent
         .Top = Range("R13").Top
         .Left = Range("R13").Left
         .Height = Range("13:42").Height
         .Width = Range("R:Z").Width
End With

'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
Labels = tbReasonCodes.Columns(3).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

Sub CreatePie()

With Sheets("Scorecard (2)")
NumCharts = .ChartObjects.Count
If NumCharts > 0 Then
For i = NumCharts To 1 Step -1
.ChartObjects(i).Delete
Next i
End If
End With

Charts.Add
With ActiveChart
    .ChartType = xlPie
    .SetSourceData Source:=Sheets("RCSupport").Range("F1:H28"), PlotBy:=xlColumns
    .ChartTitle.Text = "Schedule Delay Averages # of Days/Store"
    .ShowAllFieldButtons = False
    .Legend.Delete
    .ApplyDataLabels xlDataLabelsShowValue, xlDataLabelsPercent
         With .SeriesCollection(1)
         .HasLeaderLines = False
         With .DataLabels
         .ShowCategoryName = True
         .ShowValue = True
         .ShowPercentage = True
         .Position = xlLabelPositionBestFit
         .Font.Size = 11
         .Font.ColorIndex = 2
         End With
         End With
    .Location Where:=xlLocationAsObject, Name:="Scorecard (2)"
End With

With ActiveChart.Parent
         .Top = Range("A13").Top
         .Left = Range("A13").Left
         .Height = Range("13:42").Height
         .Width = Range("A:K").Width
End With

Charts.Add
With ActiveChart
    .ChartType = xlPie
    .SetSourceData Source:=Sheets("Pivots").Range("A4:B7"), PlotBy:=xlColumns
    .ChartTitle.Text = "Stores Complete at Open"
    .ShowAllFieldButtons = False
    .Legend.Delete
    .ApplyDataLabels xlDataLabelsShowValue, xlDataLabelsPercent
         With .SeriesCollection(1)
         .HasLeaderLines = False
         With .DataLabels
         .ShowCategoryName = True
         .ShowValue = True
         .ShowPercentage = True
         .Position = xlLabelPositionBestFit
         .Font.Size = 11
         .Font.ColorIndex = 2
         End With
         End With
    .Location Where:=xlLocationAsObject, Name:="Scorecard (2)"
End With

With ActiveChart.Parent
         .Top = Range("L13").Top
         .Left = Range("L13").Left
         .Height = Range("13:42").Height
         .Width = Range("L:Q").Width
End With

Charts.Add
With ActiveChart
    .ChartType = xlPie
    .SetSourceData Source:=Sheets("Pivots").Range("F4:G9"), PlotBy:=xlColumns
    .ChartTitle.Text = "Cost Variance"
    .ShowAllFieldButtons = False
    .Legend.Delete
    .ApplyDataLabels xlDataLabelsShowValue, xlDataLabelsPercent
         With .SeriesCollection(1)
         .HasLeaderLines = False
         With .DataLabels
         .ShowCategoryName = True
         .ShowValue = True
         .ShowPercentage = True
         .Position = xlLabelPositionBestFit
         .Font.Size = 11
         .Font.ColorIndex = 2
         End With
         End With
    .Location Where:=xlLocationAsObject, Name:="Scorecard (2)"
End With

With ActiveChart.Parent
         .Top = Range("R13").Top
         .Left = Range("R13").Left
         .Height = Range("13:42").Height
         .Width = Range("R:Z").Width
End With

'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
Labels = tbReasonCodes.Columns(3).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

0
Comment
Question by:jmac001
2 Comments
 
LVL 49

Accepted Solution

by:
Rgonzo1971 earned 500 total points
ID: 39697531
Hi,

pls try

Sub CreatePie1()

For Each cht In Sheets("Scorecard (2)").ChartObjects
    cht.Delete
Next

Charts.Add
With ActiveChart
    .ChartType = xlPie
    .SetSourceData Source:=Sheets("RCSupport").Range("F1:H28"), PlotBy:=xlColumns
    .ChartTitle.Text = "Schedule Delay Averages # of Days/Store"
    .ShowAllFieldButtons = False
    .Legend.Delete
    .ApplyDataLabels xlDataLabelsShowValue, xlDataLabelsPercent
         With .SeriesCollection(1)
         .HasLeaderLines = False
         With .DataLabels
         .ShowCategoryName = True
         .ShowValue = True
         .ShowPercentage = True
         .Position = xlLabelPositionBestFit
         .Font.Size = 11
         .Font.ColorIndex = 2
         End With
         End With
    .Location Where:=xlLocationAsObject, Name:="Scorecard (2)"
End With

With ActiveChart.Parent
         .Top = Range("A13").Top
         .Left = Range("A13").Left
         .Height = Range("13:42").Height
         .Width = Range("A:K").Width
End With

Charts.Add
With ActiveChart
    .ChartType = xlPie
    .SetSourceData Source:=Sheets("Pivots").Range("A4:B7"), PlotBy:=xlColumns
    .ChartTitle.Text = "Stores Complete at Open"
    .ShowAllFieldButtons = False
    .Legend.Delete
    .ApplyDataLabels xlDataLabelsShowValue, xlDataLabelsPercent
         With .SeriesCollection(1)
         .HasLeaderLines = False
         With .DataLabels
         .ShowCategoryName = True
         .ShowValue = True
         .ShowPercentage = True
         .Position = xlLabelPositionBestFit
         .Font.Size = 11
         .Font.ColorIndex = 2
         End With
         End With
    .Location Where:=xlLocationAsObject, Name:="Scorecard (2)"
End With

With ActiveChart.Parent
         .Top = Range("L13").Top
         .Left = Range("L13").Left
         .Height = Range("13:42").Height
         .Width = Range("L:Q").Width
End With

Charts.Add
With ActiveChart
    .ChartType = xlPie
    .SetSourceData Source:=Sheets("Pivots").Range("F4:G9"), PlotBy:=xlColumns
    .ChartTitle.Text = "Cost Variance"
    .ShowAllFieldButtons = False
    .Legend.Delete
    .ApplyDataLabels xlDataLabelsShowValue, xlDataLabelsPercent
         With .SeriesCollection(1)
         .HasLeaderLines = False
         With .DataLabels
         .ShowCategoryName = True
         .ShowValue = True
         .ShowPercentage = True
         .Position = xlLabelPositionBestFit
         .Font.Size = 11
         .Font.ColorIndex = 2
         End With
         End With
    .Location Where:=xlLocationAsObject, Name:="Scorecard (2)"
End With

With ActiveChart.Parent
         .Top = Range("R13").Top
         .Left = Range("R13").Left
         .Height = Range("13:42").Height
         .Width = Range("R:Z").Width
End With

'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
Labels = tbReasonCodes.Columns(3).Value
Colors = tbReasonCodes.Columns(4).Value
For Each cht In Sheets("Scorecard (2)").ChartObjects

    NumPoints = cht.Chart.SeriesCollection(1).Points.Count
    
    For x = 1 To NumPoints
        Set pt = cht.Chart.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
Next
End Sub

Open in new window

Regards
0
 

Author Closing Comment

by:jmac001
ID: 39698153
Wonderful, thanks I can't master loops for anything
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Using Word 2013, I was experiencing some incredible lag when typing.  Here's what worked for me....
In this article we discuss how to recover the missing Outlook 2011 for Mac data like Emails and Contacts manually.
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…

910 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

22 Experts available now in Live!

Get 1:1 Help Now