[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

Combining VBA to make pies and color slices

Posted on 2013-12-04
2
Medium Priority
?
389 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 54

Accepted Solution

by:
Rgonzo1971 earned 2000 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

Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

Question has a verified solution.

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

We live in a world of interfaces like the one in the title picture. VBA also allows to use interfaces which offers a lot of possibilities. This article describes how to use interfaces in VBA and how to work around their bugs.
Currently, there is an issue with being able to copy values from an external application to a dropdown list in Project Web Access (PWA).  The standard copy and paste methods don't seem to work properly. Here is a way to accomplish this task to s…
The viewer will learn how to simulate a series of coin tosses with the rand() function and learn how to make these “tosses” depend on a predetermined probability. Flipping Coins in Excel: Enter =RAND() into cell A2: Recalculate the random variable…
The viewer will learn how to  create a slide that will launch other presentations in Microsoft PowerPoint. In the finished slide, each item launches a new PowerPoint presentation and when each is finished it automatically comes back to this slide: …

873 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