使用 vba 创建“色标”（避免条件格式）答案

【问题标题】：Creating a "color scale" using vba (avoiding conditional formatting)使用 vba 创建“色标”（避免条件格式）
【发布时间】：2015-03-28 19:51:00
【问题描述】：

我正在寻找一种通过 VBA 代码但不是通过应用一些条件格式将色阶应用于一组单元格的方法...我想将它们应用为静态颜色（InteriorColor )

我搜索了很多 excel 网站、google 和 stackoverflow，但一无所获：(

对于我的情况，如果你看下图：

你可以看到我已经给它一个色阶，在这个例子中虽然我已经通过条件格式完成了色阶。我想通过 VBA 创建色阶 但它必须避免使用条件格式，我想为单元格分配内部颜色，以便颜色是静态的，这使得它们在所有移动 excel 查看器上可见，速度更快，如果我要删除任何数字/行，则不会改变。

以下是一些示例数据只需将其保存在 csv 中并在 excel 中打开即可查看 excel 中的数据：P：

Data 1 (Yes there are blanks),Data 2,Data 3,Data 4,Data 5,Data 6
155.7321504,144.6395913,1,-4,-9.3844,0.255813953
113.0646481,120.1609771,5,-2,-2.5874,0.088082902
126.7759917,125.3691519,2,0,-0.0004,0.107843137
,0,7,,,0.035714286
123.0716084,118.0409686,4,0,0.3236,0.118881119
132.4137536,126.5740362,3,-2,-3.8814,0.090909091
70,105.9874422,6,-1,-0.3234,0.103896104

我确实在 python 中使用了以下代码，但显然我不能在 VBA 中使用此代码，以下代码成功地将十六进制颜色分配给预定义的 50 种颜色数组中的数字，因此非常准确.

def mapValues(values):
    nValues = np.asarray(values, dtype="|S8")
    mask = (nValues != '')
    maskedValues = [float(i.split('%')[0]) for i in nValues[mask]]
    colorMap = np.array(['#F8696B', '#F86E6C', '#F8736D', '#F8786E', '#F97E6F', '#F98370', '#F98871', '#FA8E72', '#FA9373', '#FA9874', '#FA9E75', '#FBA376', '#FBA877', '#FBAD78', '#FCB379', '#FCB87A', '#FCBD7B', '#FCC37C', '#FDC87D', '#FDCD7E', '#FDD37F', '#FED880', '#FEDD81', '#FEE382', '#FEE883', '#FCEB84', '#F6E984', '#F0E784', '#E9E583', '#E3E383', '#DCE182', '#D6E082', '#D0DE82', '#C9DC81', '#C3DA81', '#BDD881', '#B6D680', '#B0D580', '#AAD380', '#A3D17F', '#9DCF7F', '#96CD7E', '#90CB7E', '#8ACA7E', '#83C87D', '#7DC67D', '#77C47D', '#70C27C', '#6AC07C', '#63BE7B'])
    _, bins = np.histogram(maskedValues, 49)
    try:
        mapped = np.digitize(maskedValues, bins)
    except:
        mapped = int(0)
    nValues[mask] = colorMap[mapped - 1]
    nValues[~mask] = "#808080"
    return nValues.tolist()

任何人都有任何想法，或者以前有人用 VBA 做过。

【问题讨论】：

就是这样，我的单元格中没有十六进制颜色...我有数字，但我无法进入十六进制颜色阶段
@Smandoli 这可能适用于大量受众，因为它正在尝试执行条件格式色标 这是一个常用功能，但通过 vba 将条件格式设置为 100 % 移动兼容，并使其在某些情况下更快、更静态和更好。您尝试在 Google 表格中打开具有条件格式颜色比例的工作表，但它们都不起作用，就像您有一个 vba 脚本将颜色添加到正确的比例一样，它将是可见的。

标签： vba excel excel-2007 excel-2013

【解决方案1】：

上面的答案应该有效。不过颜色还是和 Excel 不一样...

要重新创建与 Excel 颜色格式完全相同的内容，并在代码中更直接一点：

rgb(cr,cg,cb)

color1: red - rgb(248,105,107)

color2:green - rgb(99,190,123)

color3：蓝色 - rgb(255,235,132)

代码：

Sub HeatMapOnNOTSorted()

Dim val_min, val_max, val_mid As Double
Dim cr, cg, cy As Double


Dim mysht As Worksheet
Dim TargetRgn As Range

Set mysht = Sheets("Sheet1")
Set TargetRgn = mysht.Range("c4:d9") '<-Change whatever range HERE

'get the min&max value of the range
val_min = Application.WorksheetFunction.Min(TargetRgn)
val_max = Application.WorksheetFunction.Max(TargetRgn)
val_mid = 0.5 * (val_min + val_max)


For Each rgn In TargetRgn

    ' three color map min-mid-max
    ' min -> mid: green(99,190,123)-> yellow(255,235,132)
        If rgn.Value <= val_mid Then
            cr = 99 + (255 - 99) * (rgn.Value - val_min) / (val_mid - val_min)
            cg = 190 + (235 - 190) * (rgn.Value - val_min) / (val_mid - val_min)
            cb = 123 + (132 - 123) * (rgn.Value - val_min) / (val_mid - val_min)
        Else
    ' mid->max: yellow(255,235,132) -> red(248,105,107)
            cr = 255 + (248 - 255) * (rgn.Value - val_mid) / (val_max - val_mid)
            cg = 235 + (105 - 235) * (rgn.Value - val_mid) / (val_max - val_mid)
            cb = 132 + (107 - 132) * (rgn.Value - val_mid) / (val_max - val_mid)

        End If
    rgn.Interior.Color = RGB(cr, cg, cb)


Next rgn

End Sub

【讨论】：

【解决方案2】：

您始终可以使用 python 脚本根据 csv 数据生成十六进制颜色，然后只需读取保存生成的十六进制颜色的 csv 文件并转换 rgb，然后将内部颜色设置为 rgb 结果的颜色。

Sub HexExample()
    Dim i as Long
    Dim LastRow as Long
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To LastRow
        Cells(i, "B").Interior.Color = HexConv(Cells(i, "A"))
    Next
End Sub

Public Function HexConv(ByVal HexColor As String) As String
    Dim Red As String
    Green As String
    Blue As String
    HexColor = Replace(HexColor, "#", "")
    Red = Val("&H" & Mid(HexColor, 1, 2))
    Green = Val("&H" & Mid(HexColor, 3, 2))
    Blue = Val("&H" & Mid(HexColor, 5, 2))

    HexConv = RGB(Red, Green, Blue)
End Function

【讨论】：

嗯，这比所有其他建议都好，除了我自己的答案。您建议如何匹配数据以应用十六进制颜色？
不是最好的想法，但只需按行号，然后是 csv 格式，例如 (1,#FFFFFF,null,#000000) 会将行 a1 设置为白色，b1 设置为无填充，c1 设置为黑色。这样它并不复杂，并且可以很容易地修改。希望对您有所帮助。

【解决方案3】：

我已经找到了正确的答案，其实很简单。您所要做的就是添加条件格式，然后将.Interior.Color 设置为与.DisplayFormat.Interior.Color 相同，然后删除条件格式。

这将完全按照主帖中的要求进行；如果您想将其作为后备，则不要删除条件格式。

' Select Range
Range("A2:A8").Select

' Set Conditional
Selection.FormatConditions.AddColorScale ColorScaleType:=3
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).ColorScaleCriteria(1).Type = xlConditionValueLowestValue
With Selection.FormatConditions(1).ColorScaleCriteria(1).FormatColor
    .Color = 7039480
    .TintAndShade = 0
End With
Selection.FormatConditions(1).ColorScaleCriteria(2).Type = xlConditionValuePercentile
Selection.FormatConditions(1).ColorScaleCriteria(2).Value = 50
With Selection.FormatConditions(1).ColorScaleCriteria(2).FormatColor
    .Color = 8711167
    .TintAndShade = 0
End With
Selection.FormatConditions(1).ColorScaleCriteria(3).Type = xlConditionValueHighestValue
With Selection.FormatConditions(1).ColorScaleCriteria(3).FormatColor
    .Color = 8109667
    .TintAndShade = 0
End With

' Set Static
For i = 1 To Selection.Cells.Count
    Selection.Cells(i).Interior.Color = Selection.Cells(i).DisplayFormat.Interior.Color
Next

' Delete Conditional
Selection.Cells.FormatConditions.Delete

希望这对将来的某人有所帮助。

【讨论】：

【解决方案4】：

假设：

A1:A40 中的值。

Sub M_snb()
 [a1:A40] = [if(A1:A40="",0,A1:A40)]

 sn = [index(rank(A1:A40,A1:A40),)]
 For j = 1 To UBound(sn)
   If Cells(j, 1) <> 0 Then Cells(j, 1).Interior.Color = RGB(Int(sn(j, 1) * 255 / 40), Abs(sn(j, 1) > UBound(sn) \ 2), 255 - Int((sn(j, 1) - 1) * (255 / 40)))
 Next

 [a1:A40] = [if(A1:A40=0,"",A1:A40)]
End Sub

【讨论】：

这没有形成正确的配色方案，如我的示例所示（248/105/107 = 红色 rgb，99/190/123 = 绿色 rgb，255/235/132 = 黄色 rgb） , 也没有忽略空白，它的排名也完全错误。（例如 23 有不同的颜色）i.imgur.com/rsHjUjL.png
我只是向您展示了如何获得您想要的答案。你有我的许可来修改代码。例如颜色的调整。检查排名：[C1:C40]=[index(rank(A1:A40,A1:A40),)]
但是颜色索引只是使用调色板并根据调色板编号分配颜色...
我根据您的意愿更改了我的代码。空单元格已被忽略。

【解决方案5】：

以下函数 CalcColorScale 将返回给定任意两种颜色的颜色和刻度。刻度是您当前数据相对于数据范围的值。例如如果您的数据是从 0 到 200，那么数据值 100 将是比例 50%(.5)

图像显示红色和蓝色之间的缩放结果

Public Sub Test()
    ' Sets cell A1 to background purple
    Sheet1.Range("A1").Interior.Color = CalcColorScale(rgbRed, rgbBlue, 0.5)
End Sub

' color1: The starting color as a long
' color2: The end color as a long
' dScale: This is the percentage in decimal of the color.
Public Function CalcColorScale(color1 As Long, color2 As Long, dScale As    Double) As Long

    ' Convert the colors to red, green, blue components
    Dim r1 As Long, g1 As Long, b1 As Long
    r1 = color1 Mod 256
    g1 = (color1 \ 256) Mod 256
    b1 = (color1 \ 256 \ 256) Mod 256

    Dim r2 As Long, g2 As Long, b2 As Long
    r2 = color2 Mod 256
    g2 = (color2 \ 256) Mod 256
    b2 = (color2 \ 256 \ 256) Mod 256

    CalcColorScale = RGB(CalcColorScaleRGB(r1, r2, dScale) _
                        , CalcColorScaleRGB(g1, g2, dScale) _
                        , CalcColorScaleRGB(b1, b2, dScale))
End Function

' Calculates the R,G or B for a color between two colors based the percentage between them
' e.g .5 would be halfway between the two colors
 Public Function CalcColorScaleRGB(color1 As Long, color2 As Long, dScale As Double) As Long
    If color2 < color1 Then
        CalcColorScaleRGB = color1 - (Abs(color1 - color2) * dScale)
    ElseIf color2 > color1 Then
        CalcColorScaleRGB = color1 + (Abs(color1 - color2) * dScale)
    Else
        CalcColorScaleRGB = color1
    End If
End Function

【讨论】：

哦，伙计，我刚刚完成了我已经工作了半个多小时的完全相同的概念（只是不太漂亮），现在我觉得没用了：D 你得到了我的投票，我没有甚至不知道你可以这样做 "b1 = (color1 \ 256 \ 256) Mod 256" 来获得 RGB 分量，很酷。
谢谢。很高兴你喜欢它，
我提供的代码将根据比例返回颜色。你需要确定你的规模。在您的示例单元格 A2:A8 的范围为 13 到 38。因此，单元格 A2（值为 32）的比例约为 0.75。您需要遍历每个单元格并根据该单元格中的值传递 CalcColorScale 适当的范围。
@PaulKelly 这就是我得到的：i.imgur.com/lq5qCvZ.png 在任何情况下，它都会变成紫色。 ://
@PaulKelly，很好的解决方案，但它需要一些测试（你从我这里得到 +1）。 @Ryflex，可以获得 3 个色标...将数字从 0 到 100 第 5 步放在任何列中 >> 为每个具有值的单元格运行循环 >>If Cell < 50 Then : Cell.Interior.Color = CalcColorScale(vbRed, vbYellow, Cell / 50) : Else : Cell.Interior.Color = CalcColorScale(vbYellow, vbGreen, (Cell - 50) / 50) : End If 结果我有红色（0）的颜色>> 到黄色 (50) >> 到绿色 (100)。

【解决方案6】：

也许这就是你要找的东西：

Sub a()
    Dim vCM As Variant

    vCM = Array("F8696B", "FED880", "63BE7B") ' as many as you need
    ' Array's lower bound is 0 unless it is set to another value using Option Base
    ActiveCell.Interior.Color = Application.WorksheetFunction.Hex2Dec(CStr(vCM(2))) ' off-green in the active cell
End Sub

如果你想放弃十六进制并使用颜色值，那么上面的就变成了这个

Sub b()
    Dim vCM As Variant

    vCM = Array(16279915, 16701568, 6536827) ' as many as you need
    ' Array's lower bound is 0 unless it is set to another value using Option Base
    ActiveCell.Interior.Color = vCM(2) ' 6536827 setts an off-green in the active cell
End Sub

如果您不知道如何获取颜色值，这里是手动过程：

对单元格应用内部颜色。确保选中单元格。
在 VBE 的立即窗口中，执行 ?ActiveCell.Interior.Color 以获取您在步骤 1 中应用的内部颜色的颜色编号。

祝你好运。

【讨论】：

这并没有真正的帮助，即使我在 python 中有一个可供参考，我也不知道如何进入十六进制阶段。
@ryflex 什么是“十六进制阶段”？！
决定使用什么颜色的部分...假设你有 A1:A15 里面有数字，你可以很容易地创建一个条件格式规则来在单元格上放置适当的颜色但是如何我通过 vba 获得相同的颜色而不使用条件格式？
一点也不错，python 代码对数字数据进行排序并为其分配一个十六进制颜色，这与我想要的 VBA 相同，在这种情况下它可以是十六进制，excel 的 @987654325 @s 或 RGB。我帖子的第一行用一个简单的短语总结了它：I'm looking for a way to apply a color scale to a set of cells via VBA code but not by applying some conditional formatting... I want to apply them as static colors (InteriorColor) 如果你检查我对我帖子的编辑，你会看到我添加了一个截图示例。
@Ryflex 我已经阅读了您的编辑（谢谢）——这就是我最终理解您想要什么的方式。我不知道 python 确定你的 python 代码在做什么。如果您这样做，请用简单的英语重新表述要求（基于您提供的“编辑”图像）。目前，我在上述评论中的问题仍未得到解答。