asked on

Combining VBA to make pies and color slices

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

ASKER CERTIFIED SOLUTION

Rgonzo1971

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

jmac001

ASKER

Wonderful, thanks I can't master loops for anything