|
Also see our huge range of Charting Software . Got a Excel Chart question? Use our FREE Excel Help
The chart in both cases is a standard xy scatter plot where the plot order of each data point determines the color of the marker.
The first chart sets the data markers color but due to the limit of the color palette it produces a more stepped coloration.
The second chart uses an autoshape as a custom marker. The color of the custom marker is not restricted by the color palette so the coloration is smoother.
The code sets the data markers
color according to the points order within the data series. You can specify
the Start and finish colors and the number of steps between. In order for
the code below to work you will need to create 2 charts and insert a
autoshape onto a worksheet. The autoshape should be named Marker.
To name the autoshape select it and enter the new name in the Name box next
to the formula bar.
The code allows you to specify the Start and finish color of your spectrum. You can also specify the number of colors to define within the span.Code module: MSpectrum
Option Explicit
Sub Main() Dim clsSpectrum As CSpectrum Set clsSpectrum = New CSpectrum With clsSpectrum .Count = 56 ' number of colours in spectrum .Start Color = RGB(0, 0, 255) ' Blue .EndColor = RGB(255, 0, 0) ' Red .CreateSpectrum End With UsingMarkers clsSpectrum, ActiveSheet.ChartObjects(1).Chart UsingCustomMarkers clsSpectrum, ActiveSheet.ChartObjects(2).Chart End Sub Sub UsingMarkers(Spectrum As CSpectrum, Cht As Chart) ' ' Using builtin color palette ' Dim lngIndex As Long Dim intPoint As Integer With Cht With .SeriesCollection(1) For intPoint = 1 To .Points.Count lngIndex = intPoint * (Spectrum.Count / .Points.Count) With .Points(intPoint) .MarkerBackgroundColor = Spectrum.SpectrumColor(lngIndex) .MarkerForegroundColor = Spectrum.SpectrumColor(lngIndex) End With Next End With End With End Sub Sub UsingCustomMarkers(Spectrum As CSpectrum, Cht As Chart) ' ' Use a shape as a custom marker ' Dim shpMarker As Shape Dim lngIndex As Long Dim intPoint As Integer Application.ScreenUpdating = False Set shpMarker = ActiveSheet.Shapes("Marker") With Cht With .SeriesCollection(1) For intPoint = 1 To .Points.Count lngIndex = intPoint * (Spectrum.Count / .Points.Count) shpMarker.Fill.ForeColor.RGB = Spectrum.SpectrumColor(lngIndex) shpMarker.CopyPicture .Points(intPoint).Paste Next End With End With Application.ScreenUpdating = True End Sub |
Class module: CSpectrum
Option Explicit
Private Enum enumSpectrum Red = 1 Green Blue End Enum Private m_lngStart Color As Long Private m_lngEndColor As Long Private m_lngCountColor As Long Private m_lngSpectrum() As Long Private m_blnUpdatedSpectrum As Boolean Public Property Let Count(RHS As Long) If RHS < 1 Then m_lngCountColor = 1 ElseIf RHS > 255 Then m_lngCountColor = 255 Else m_lngCountColor = RHS End If m_blnUpdatedSpectrum = False End Property Public Property Get Count() As Long Count = m_lngCountColor End Property Public Sub CreateSpectrum() ' ' Calculate the spread of colours ' Dim lngIndex As Long Dim lngColor As Long Dim sngSpreadRed As Single Dim sngSpreadGreen As Single Dim sngSpreadBlue As Single Dim sngRed As Single Dim sngGreen As Single Dim sngBlue As Single If m_lngCountColor = 0 Then m_lngCountColor = 2 ReDim m_lngSpectrum(m_lngCountColor) As Long m_lngSpectrum(1) = m_lngStart Color m_lngSpectrum(2) = m_lngEndColor m_blnUpdatedSpectrum = True End If ReDim m_lngSpectrum(m_lngCountColor) As Long m_lngSpectrum(1) = m_lngStart Color m_lngSpectrum(m_lngCountColor) = m_lngEndColor sngRed = CSng(m_Color2RGB(m_lngSpectrum(1), Red)) sngGreen = CSng(m_Color2RGB(m_lngSpectrum(1), Green)) sngBlue = CSng(m_Color2RGB(m_lngSpectrum(1), Blue)) sngSpreadRed = (m_Color2RGB(m_lngSpectrum(m_lngCountColor), Red) - sngRed) / m_lngCountColor sngSpreadGreen = (m_Color2RGB(m_lngSpectrum(m_lngCountColor), Green) - sngGreen) / m_lngCountColor sngSpreadBlue = (m_Color2RGB(m_lngSpectrum(m_lngCountColor), Blue) - sngBlue) / m_lngCountColor For lngIndex = 2 To m_lngCountColor - 1 sngRed = sngRed + sngSpreadRed sngGreen = sngGreen + sngSpreadGreen sngBlue = sngBlue + sngSpreadBlue m_lngSpectrum(lngIndex) = RGB(CInt(sngRed), CInt(sngGreen), CInt(sngBlue)) Next m_blnUpdatedSpectrum = True End Sub Private Function m_Color2RGB(Color As Long, Element As enumSpectrum) As Long ' ' Return RGB element for given color ' Select Case Element Case enumSpectrum.Red m_Color2RGB = Color \ 256 ^ 0 And 255 Case enumSpectrum.Green m_Color2RGB = Color \ 256 ^ 1 And 255 Case enumSpectrum.Blue m_Color2RGB = Color \ 256 ^ 2 And 255 End Select End Function Public Property Get SpectrumColor(Index As Long) As Long If Index > m_lngCountColor Then SpectrumColor = m_lngSpectrum(m_lngCountColor) ElseIf Index < 1 Then SpectrumColor = m_lngSpectrum(1) Else SpectrumColor = m_lngSpectrum(Index) End If End Property Public Property Let Start Color(RHS As Long) m_lngStart Color = RHS m_blnUpdatedSpectrum = False End Property Public Property Let EndColor(RHS As Long) m_lngEndColor = RHS m_blnUpdatedSpectrum = False End Property Public Property Get Start Color() As Long Start Color = m_lngStart Color End Property Public Property Get EndColor() As Long EndColor = m_lngEndColor End Property Private Sub Class_Initialize() ' default settings m_lngCountColor = 56 m_lngStart Color = RGB(0, 0, 255) ' blue m_lngEndColor = RGB(255, 0, 0) ' red m_blnUpdatedSpectrum = False CreateSpectrum End Sub |
Download Example workbook with data & Excel VBA Code.
Back to Excel Charts Index
Also see our huge range of Charting Software
New & Less Than You Think: List Managers | Working With Excel Sheets In VBA | Excel Charting Lessons | Conditional Row Delete
Excel Dashboard Reports & Excel Dashboard Charts 50% Off Become an ExcelUser Affiliate & Earn Money
Special! Free Choice of Complete Excel Training Course OR Excel Add-ins Collection on all purchases totaling over $64.00. ALL purchases totaling over $150.00 gets you BOTH! Purchases MUST be made via this site. Send payment proof to [email protected] 31 days after purchase date.
Instant Download and Money Back Guarantee on Most Software
Excel Trader Package Technical Analysis in Excel With $139.00 of FREE software!
Microsoft � and Microsoft Excel � are registered trademarks of Microsoft Corporation. OzGrid is in no way associated with Microsoft
Some of our more popular products are below...
Convert Excel Spreadsheets To Webpages | Trading In Excel | Construction Estimators | Finance Templates & Add-ins Bundle | Code-VBA | Smart-VBA | Print-VBA | Excel Data Manipulation & Analysis | Convert MS Office Applications To...... | Analyzer Excel | Downloader Excel
| MSSQL Migration
Toolkit |
Monte Carlo Add-in |
Excel
Costing Templates