none
Recolor chart with custom color in PowerPoint RRS feed

  • Question

  • Hi All,

    Can anyone help me to set the custom RGB colors to series in column chart in Powerpoint?  I have 10 RGB values, which i want to set to chart for highest to lowest value in a order (ascending or descending)

    Please see the below screenshot. I have included RGB colors value that I want to be in this chart. here is RGB colors

    RGB Code
    0, 101, 174
    53, 152, 219
    169, 209, 142
    255, 217, 102
    255, 143, 143
    214, 94, 82
    55, 184, 102
    157, 89, 130
    184, 154, 64
    255, 158, 15

    Chart Needed RGB colors

    Thanks in advance,

    kulchandra Neupane


    Tuesday, January 30, 2018 11:37 AM

Answers

  • Here Kulchandra Neupane,

    My solution is getting all points of the series into an array and then get the min value in the array. After getting the min value point, we could set its color and remove it from the array. And then get min value, color the point and remove it from array again. Do the loop 10 times. 

    I used dictionary for recording point index and point value at same time.

    Here is my simply code.

    Sub Test()
    Dim arr(1 To 10) As Variant
    arr(1) = RGB(0, 101, 174)
    arr(2) = RGB(53, 152, 219)
    arr(3) = RGB(169, 209, 142)
    arr(4) = RGB(255, 217, 102)
    arr(5) = RGB(255, 143, 143)
    arr(6) = RGB(214, 94, 82)
    arr(7) = RGB(55, 184, 102)
    arr(8) = RGB(157, 89, 130)
    arr(9) = RGB(184, 154, 64)
    arr(10) = RGB(255, 158, 15)
    
    Dim cht As Chart
    Set cht = Application.ActivePresentation.Slides(1).Shapes(1).Chart
    Dim ser As Series
    Dim PT As Point
    Set ser = cht.SeriesCollection(1)
    
    vals = cht.SeriesCollection(1).Values
    Dim dict As Dictionary
    Set dict = New Dictionary
    For i = LBound(vals) To UBound(vals)
    dict.Add i, vals(i)
    Next i
    
    For i = 1 To 10
     If dict.Count > 0 Then
     minValue = dict.Items(0)
     preDelIndex = 0
     For j = LBound(dict.Items) To UBound(dict.Items)
     If dict.Items(j) < minValue Then
     minValue = dict.Items(j)
     preDelIndex = j
     End If
     Next j
     delKey = dict.Keys(preDelIndex)
     dict.Remove delKey
     ser.Points(delKey).Format.Fill.ForeColor.RGB = arr(i)
     End If
    Next
    End Sub
    

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Thursday, February 1, 2018 1:57 AM
  • Hello Kulchandra Neupane,

    Sorry for my careless. You need add reference to Microsoft Scripting Runtime then you could use Dictionary object.

    Go to Tools->Reference, search for Microsoft Scripting Runtime and check it.

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Friday, February 2, 2018 8:10 AM

All replies

  • Here Kulchandra Neupane,

    My solution is getting all points of the series into an array and then get the min value in the array. After getting the min value point, we could set its color and remove it from the array. And then get min value, color the point and remove it from array again. Do the loop 10 times. 

    I used dictionary for recording point index and point value at same time.

    Here is my simply code.

    Sub Test()
    Dim arr(1 To 10) As Variant
    arr(1) = RGB(0, 101, 174)
    arr(2) = RGB(53, 152, 219)
    arr(3) = RGB(169, 209, 142)
    arr(4) = RGB(255, 217, 102)
    arr(5) = RGB(255, 143, 143)
    arr(6) = RGB(214, 94, 82)
    arr(7) = RGB(55, 184, 102)
    arr(8) = RGB(157, 89, 130)
    arr(9) = RGB(184, 154, 64)
    arr(10) = RGB(255, 158, 15)
    
    Dim cht As Chart
    Set cht = Application.ActivePresentation.Slides(1).Shapes(1).Chart
    Dim ser As Series
    Dim PT As Point
    Set ser = cht.SeriesCollection(1)
    
    vals = cht.SeriesCollection(1).Values
    Dim dict As Dictionary
    Set dict = New Dictionary
    For i = LBound(vals) To UBound(vals)
    dict.Add i, vals(i)
    Next i
    
    For i = 1 To 10
     If dict.Count > 0 Then
     minValue = dict.Items(0)
     preDelIndex = 0
     For j = LBound(dict.Items) To UBound(dict.Items)
     If dict.Items(j) < minValue Then
     minValue = dict.Items(j)
     preDelIndex = j
     End If
     Next j
     delKey = dict.Keys(preDelIndex)
     dict.Remove delKey
     ser.Points(delKey).Format.Fill.ForeColor.RGB = arr(i)
     End If
    Next
    End Sub
    

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Thursday, February 1, 2018 1:57 AM
  • Hi Terry,

    Thank you for the code. I tried to run but got the compile error on "Dim dict As Dictionary".

    Since I am novice in VB script. Could you please help me to make it run? I have first selected the chart and run the code. Here is the screenshot of error.

    Friday, February 2, 2018 8:02 AM
  • Hello Kulchandra Neupane,

    Sorry for my careless. You need add reference to Microsoft Scripting Runtime then you could use Dictionary object.

    Go to Tools->Reference, search for Microsoft Scripting Runtime and check it.

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Friday, February 2, 2018 8:10 AM
  • Hi Terry,

    Thanks. Now it works like Charm!

    Thank you so much :)

    Friday, February 2, 2018 9:45 AM