使用 vba 创建“色阶”（避免条件格式）
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/28217226/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Creating a "color scale" using vba (avoiding conditional formatting)
提问by Ryflex
I'm looking for a way to apply a color scale to a set of cells via VBA code but notby applying some conditional formatting... I want to apply them as static colors (InteriorColor)
我正在寻找一种通过 VBA 代码将色阶应用到一组单元格的方法，而不是通过应用一些条件格式...我想将它们应用为静态颜色 (InteriorColor)
I've searched plenty of excel sites, google and stackoverflow and found nothing :(
我搜索了很多 excel 网站、google 和 stackoverflow，但一无所获:(
For my situation if you look at the following picture:
对于我的情况，如果你看下图：
You can see I've given it a color scale, in this example though I have done the color scale via Conditional formatting. I want to create the color scale via VBA but it must avoid using conditional formatting, I want to assign interior colors to the cells so that the colors are static which makes them visible on all mobile excel viewers, faster, won't change if I was to remove any numbers/rows.
你可以看到我已经给了它一个色阶，在这个例子中虽然我已经通过条件格式完成了色阶。我想通过 VBA 创建色阶，但它必须避免使用条件格式，我想为单元格分配内部颜色，以便颜色是静态的，这使得它们在所有移动 excel 查看器上可见，速度更快，如果我不会改变是删除任何数字/行。
Here are some example data Just save it in a csv and open it in excel to see the data in excel :P:
以下是一些示例数据只需将其保存在 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
I do use the following in python but obviously I can't use this code in VBA, the following code successfully assigns hex colors to the numbers from a predefined array of 50 colors so it's pretty accurate.
我确实在 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()
Anyone have any ideas or has anyone done this before with VBA.
任何人都有任何想法，或者之前有人用 VBA 做过这件事。
采纳答案by Ryflex
I've managed to find the correct answer, it's actually rather simple. All you have to do is add conditional formatting and then set the .Interior.Colorto the same as what the .DisplayFormat.Interior.Coloris and then delete the conditional formatting.
我设法找到了正确的答案，它实际上相当简单。您所要做的就是添加条件格式，然后将 the 设置 .Interior.Color为与 the .DisplayFormat.Interior.Coloris相同，然后删除条件格式。
This will do exactly what is requested in the main post; and if you want to do it as a fallback then just don't delete the conditional formatting.
这将完全按照主要帖子中的要求进行；如果您想将其作为后备，则不要删除条件格式。
' 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
Hopefully this helps someone in the future.
希望这对将来的人有所帮助。
回答by Paul Kelly
The following function CalcColorScale will return a color given any two colors and the scale.The scale is the value of your current data relative to the range of data. e.g. if your data is from 0 to 200 then a data value 100 would be scale 50%(.5)
以下函数 CalcColorScale 将返回给定任意两种颜色和比例的颜色。比例是当前数据相对于数据范围的值。例如，如果您的数据从 0 到 200，那么数据值 100 将缩放 50%(.5)
The image shows the result of scaling between red and blue
图像显示了在红色和蓝色之间缩放的结果
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
回答by Dennis Sylvian
You could always use the python script to generate the hex colors based of csv data and then simply read the csv file holding the generated hex colors and convert rgb then set the interiorcolor to that of the rgb outcome.
您始终可以使用 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
回答by li rachel
The answers above should work. Still, the color is different that from Excel...
上面的答案应该有效。尽管如此，颜色与Excel不同......
To recreate exact the same thing as Excel color formatting, and a little more straight forward in code:
要重新创建与 Excel 颜色格式完全相同的内容，并在代码中更直接：
rgb(cr,cg,cb)
RGB（CR，CG，CB）
color1: red - rgb(248,105,107)
颜色 1：红色 - RGB（248,105,107）
color2:green - rgb(99,190,123)
颜色 2：绿色 - RGB（99,190,123）
color3: blue - rgb(255,235,132)
color3：蓝色 - rgb(255,235,132)
code:
代码：
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
回答by Gene Skuratovsky
Maybe this is what you are looking for:
也许这就是你要找的：
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
If you deside to forgo the Hex and use the color values then the above becomes this
如果您决定放弃十六进制并使用颜色值，则上述内容变为
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
In case you do not know how to get the color values, here is the manual process:
如果您不知道如何获取颜色值，这里是手动过程：
Apply an interior color to a cell. Make sure the cell is selected.
In the VBE's Immediate window, execute
?ActiveCell.Interior.Colorto get the color number for the interior color you've applied in Step 1.
将内部颜色应用于单元格。确保选中单元格。
在 VBE 的立即窗口中，执行
?ActiveCell.Interior.Color以获取您在步骤 1 中应用的内部颜色的颜色编号。
Good luck.
祝你好运。
回答by snb
assuming:
假设：
values in A1:A40.
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
