How to make a charts fill reference cell color and patterns?

Question

I have created thermometer charts which are colored based on a range (red - poor, yellow - average, green - good) from cells in my sheet. That is, the chart references the color of the cell to determine fill color. However, when printed in black and white the red and green are difficult to distinguish. I do not want to abandon the stoplight coloring because it is intuitive for my audience.

I am trying to figure out how to get the chart fill to reflect the pattern in the cells in addition to the color. My current syntax (for color fill) is below.

Sub ColorByValueSMICAUpdate()
  Dim rPatterns As Range
  Dim iPattern As Long
  Dim vPatterns As Variant
  Dim iPoint As Long
  Dim vValues As Variant
  Dim rValue As Range

  Set rPatterns = ActiveSheet.Range("P5:P11")
  vPatterns = rPatterns.Value
  With ActiveChart.SeriesCollection(1)
    vValues = .Values
    For iPoint = 1 To UBound(vValues)
      For iPattern = 1 To UBound(vPatterns)
        If vValues(iPoint) <= vPatterns(iPattern, 1) Then
          .Points(iPoint).Format.Fill.ForeColor.RGB = _
              rPatterns.Cells(iPattern, 1).Interior.Color
          Exit For
        End If
      Next
    Next
  End With
End Sub

Thank you!

Answer 1

The key to this problem is that the fill on the cell is an interior.pattern object and the fill on the chart is a format.fill.patterned object. The only way is to convert a pattern into a patterned as stated above by David Zemens.

The code below will works but you may want to play around with which pattern converts to which patterned.

TRIED AND TESTED

Sub ColorByValueSMICAUpdate()
  Dim rPatterns As Range
  Dim iPattern As Long
  Dim vPatterns As Variant
  Dim iPoint As Long
  Dim vValues As Variant
  Dim rValue As Range

  Set rPatterns = ActiveSheet.Range("P5:P11")
  vPatterns = rPatterns.Value
  With ActiveChart.SeriesCollection(1)
    vValues = .Values
    For iPoint = 1 To UBound(vValues)
      For iPattern = 1 To UBound(vPatterns)
        If vValues(iPoint) <= vPatterns(iPattern, 1) Then
          .Points(iPoint).Format.Fill.ForeColor.RGB = _
              rPatterns.Cells(iPattern, 1).Interior.Color
          .Points(iPoint).Format.Fill.Patterned _
              ConvertPatternToPattened(rPatterns.Cells(iPattern, 1).Interior.pattern)
          Exit For
        End If
      Next
    Next
  End With
End Sub

Private Function ConvertPatternToPattened(pattern As Integer) As Integer

' To change the converted patterns please refer to the two references below
'
' Patterned List - http://msdn.microsoft.com/en-us/library/office/aa195819(v=office.11).aspx
' Pattern List - http://msdn.microsoft.com/en-us/library/microsoft.office.interop.excel.interior.pattern(v=office.15).aspx


Dim Result As Integer

Result = msoPattern90Percent

Select Case pattern
    Case xlPatternChecker
        Result = msoPatternLargeCheckerBoard
    Case xlPatternCrissCross
        Result = msoPattern90Percent
    Case xlPatternDown
        Result = msoPatternNarrowVertical
    Case xlPatternGray16
        Result = msoPattern20Percent
    Case xlPatternGray25
        Result = msoPattern25Percent
    Case xlPatternGray50
        Result = msoPattern50Percent
    Case xlPatternGray75
        Result = msoPattern75Percent
    Case xlPatternGray8
        Result = msoPattern10Percent
    Case xlPatternGrid
        Result = msoPatternSmallGrid
    Case xlPatternHorizontal
        Result = msoPatternLightHorizontal
    Case xlPatternLightDown
        Result = msoPatternLightVertical
    Case xlPatternLightHorizontal
        Result = msoPatternNarrowHorizontal
    Case xlPatternLightUp
        Result = msoPatternLightVertical
    Case xlPatternLightVertical
        Result = msoPattern90Percent
    Case xlPatternSemiGray75
        Result = msoPattern80Percent
    Case xlPatternSolid
        Result = msoPattern90Percent
    Case xlPatternUp
        Result = msoPatternDarkVertical
    Case xlPatternVertical
        Result = msoPatternDashedVertical
    Case Else
        Result = msoPattern90Percent
End Select

ConvertPatternToPattened = Result

End Function