Creating full-spectrum color gradients in bar chart based on input value

Ushiwakka

New Member
Joined
Jan 2, 2021
Messages
3
Office Version
  1. 2016
Platform
  1. Windows
I'm creating a resource for the stats behind the mechanics of a video game I'm designing and would like the value of each stat to scale from red (lowest) through yellow, to green, and finally cyan (highest). I'd post an image link but I'm not allowed to yet; the stat bars for the Pokemon on the Smogon site is very similar to what I'm going for.

Ideally the color and length of the bar would automate once a number is input. In Excel the fill effects only allow for two colors rather than a gradual spectrum; any help on how to implement this is much appreciated. (using version 2016)
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Welcome

Something like this? Do you have the image icon shown below?

gradient.PNG


bar options.PNG
 
Upvote 0
Try this code:

spectrum.PNG


VBA Code:
Sub Grad()
Dim p As Point, sc As Series, arr, i%, fr!
Set sc = ActiveChart.FullSeriesCollection(1)
arr = sc.Values
For i = LBound(arr) To UBound(arr)
    Set p = ActiveChart.FullSeriesCollection(1).Points(i)
    p.Format.Fill.TwoColorGradient msoGradientVertical, 1
    fr = arr(i) / WorksheetFunction.Max(arr)
    Select Case True
        Case fr < 0.33
            p.Format.Fill.ForeColor.RGB = RGB(250, 10, 10)
            p.Format.Fill.GradientStops.Insert RGB(250, 10, 10), 0
            p.Format.Fill.GradientStops.Insert RGB(250, 250, 10), 0.99
        Case fr > 0.33 And fr < 0.66
            p.Format.Fill.GradientStops.Insert RGB(250, 10, 10), 0
            p.Format.Fill.GradientStops.Insert RGB(250, 250, 10), 0.33 / fr
            p.Format.Fill.GradientStops.Insert RGB(10, 250, 10), 0.99
        Case fr > 0.66 And fr < 0.9
            p.Format.Fill.GradientStops.Insert RGB(250, 10, 10), 0
            p.Format.Fill.GradientStops.Insert RGB(250, 250, 10), 0.33 / fr
            p.Format.Fill.GradientStops.Insert RGB(10, 250, 10), 0.66 / fr
        Case fr > 0.9
            p.Format.Fill.ForeColor.RGB = RGB(10, 250, 250)
            p.Format.Fill.GradientStops.Insert RGB(250, 10, 10), 0 / fr
            p.Format.Fill.GradientStops.Insert RGB(250, 250, 10), 0.33 / fr
            p.Format.Fill.GradientStops.Insert RGB(10, 250, 10), 0.66 / fr
            p.Format.Fill.GradientStops.Insert RGB(10, 250, 250), 0.9 / fr
    End Select
Next
End Sub
 
Upvote 0
Try this code:

View attachment 29078

VBA Code:
Sub Grad()
Dim p As Point, sc As Series, arr, i%, fr!
Set sc = ActiveChart.FullSeriesCollection(1)
arr = sc.Values
For i = LBound(arr) To UBound(arr)
    Set p = ActiveChart.FullSeriesCollection(1).Points(i)
    p.Format.Fill.TwoColorGradient msoGradientVertical, 1
    fr = arr(i) / WorksheetFunction.Max(arr)
    Select Case True
        Case fr < 0.33
            p.Format.Fill.ForeColor.RGB = RGB(250, 10, 10)
            p.Format.Fill.GradientStops.Insert RGB(250, 10, 10), 0
            p.Format.Fill.GradientStops.Insert RGB(250, 250, 10), 0.99
        Case fr > 0.33 And fr < 0.66
            p.Format.Fill.GradientStops.Insert RGB(250, 10, 10), 0
            p.Format.Fill.GradientStops.Insert RGB(250, 250, 10), 0.33 / fr
            p.Format.Fill.GradientStops.Insert RGB(10, 250, 10), 0.99
        Case fr > 0.66 And fr < 0.9
            p.Format.Fill.GradientStops.Insert RGB(250, 10, 10), 0
            p.Format.Fill.GradientStops.Insert RGB(250, 250, 10), 0.33 / fr
            p.Format.Fill.GradientStops.Insert RGB(10, 250, 10), 0.66 / fr
        Case fr > 0.9
            p.Format.Fill.ForeColor.RGB = RGB(10, 250, 250)
            p.Format.Fill.GradientStops.Insert RGB(250, 10, 10), 0 / fr
            p.Format.Fill.GradientStops.Insert RGB(250, 250, 10), 0.33 / fr
            p.Format.Fill.GradientStops.Insert RGB(10, 250, 10), 0.66 / fr
            p.Format.Fill.GradientStops.Insert RGB(10, 250, 250), 0.9 / fr
    End Select
Next
End Sub
Thank you, but is it possible to get solid colors as in the image I posted? Each bar wouldn't have it's own gradient, but the range would be on a gradient that narrows to a single color for a given value. Or is the image you posted not indicative of the final product?
 
Upvote 0
New version:

VBA Code:
Sub Grad()
Dim p As Point, sc As Series, arr, i%, fr!
arr = ActiveChart.FullSeriesCollection(1).Values
For i = LBound(arr) To UBound(arr)
    Set p = ActiveChart.FullSeriesCollection(1).Points(i)
    fr = arr(i) / WorksheetFunction.Max(arr)
    Select Case True
        Case fr < 0.33
            p.Format.Fill.ForeColor.RGB = RGB(250, 10, 10)
        Case fr > 0.33 And fr < 0.66
            p.Format.Fill.ForeColor.RGB = RGB(250, 250, 10)
        Case fr > 0.66 And fr < 0.9
            p.Format.Fill.ForeColor.RGB = RGB(10, 250, 10)
        Case fr > 0.9
            p.Format.Fill.ForeColor.RGB = RGB(10, 250, 250)
    End Select
Next
End Sub
 
Upvote 0

Forum statistics

Threads
1,212,927
Messages
6,110,725
Members
448,294
Latest member
jmjmjmjmjmjm

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top