How to get colors made by color scale of conditional formatting of Excel 2012 through VBA code
if no better answer is provided, you can try this workaround:
- link / copy your data to cells under the chart (with formulas like
=Sheet1!A1
) - apply the same conditional formatting
- hide the values (with custom number format like
""
, i.e. empty string literal (2 double quotes)) - make the chart transparent
- align the cells with the chart
UPDATE:
or you can try to compute the color by linear approximation for each R, G, B channel if the conditional format uses only 2 base colors (r1, g1, b1) and (r2, g2, b2) for 2 corner cases which can be
min
andmax
value, e.g.: 0 - 4 000min
andmax
percent, e.g.: 10% - 90%
(i believe you can use % * [max_value - min_value] to get the actual value)min
andmax
percentile, e.g.: 0th percentile - 100th percentile
for percent / percentile options you first need to convert an actual value to the percent / percentile value, then if value < min
or value > max
use the corner colors, otherwise:
r = r1 + (r2 - r1) * (value - min_value) / (max_value - min_value)
g = ...
b = ...
This will copy a picture of a cell to the top-left corner of a chartobject on the same worksheet. Note the picture is linked to the copied cell - if the value or formatting color changes it will change to match.
Sub Tester()
CopyLinkedPicToPlot ActiveSheet.Range("E4"), "Chart 2"
End Sub
Sub CopyLinkedPicToPlot(rngCopy As Range, chtName As String)
Dim cht As ChartObject
Set cht = ActiveSheet.ChartObjects(chtName)
rngCopy.Copy
With rngCopy.Parent.Pictures.Paste(Link:=True)
.Top = cht.Top
.Left = cht.Left
End With
End Sub
EDIT: I just tested this with a fairly small 4x8 matrix of cells/charts and the performance is pretty bad! Might be better just pasting without Link:=True ...
This is not specific to your problem but is easily modified to solve your problem...
Sub CopyCondFill()
Dim FromSheet As Object
Dim ToSheet As Object
Dim FromSheetName as String
Dim ToSheetName as String
Dim ToRange As Range
Dim StrRange As String
'''Sheet with formatting you want to copy
FromSheetName = "YourSheetsName"
Set FromSheet = Application.ThisWorkbook.Sheets(FromSheetName )
'''Start of range within sheet you want to copy
FromFirstRow = 3
FromFirstCol = 2
'''Sheet you want to copy formatting to
ToSheetName = "YourSheetsName"
Set ToSheet = Application.ThisWorkbook.Sheets(ToSheetName)
'''range to copy formatting to
ToFirstRow = 3
ToFirstCol = 2
'''NOTE: Adjust row/column to take lastrow/lastcol from or enter value manually
ToLastRow = FromSheet.Cells(Rows.Count, 1).End(xlUp).Row
ToLastCol = FromSheet.Cells(2, Columns.Count).End(xlToLeft).Column
Set ToRange = ToSheet.Range(Cells(ToFirstRow, ToFirstCol), Cells(ToLastRow, ToLastCol))
'''Apply formatting to range
For Each cell In ToRange
StrRange = cell.Address(0, 0)
ToSheet.Range(StrRange).Offset(ToFirstRow - FromFirstRow, ToFirstCol - FromFirstCol).Interior.Color = _
FromSheet.Range(StrRange).DisplayFormat.Interior.Color
Next cell
End Sub