[Webinar] Streamline your web hosting managementRegister Today

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 391
  • Last Modified:

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

0
jmac001
Asked:
jmac001
1 Solution
 
Rgonzo1971Commented:
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
 
jmac001Author Commented:
Wonderful, thanks I can't master loops for anything
0

Featured Post

The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now