使用 vba 创建 "color scale" （避免条件格式）
Creating a "color scale" using vba (avoiding conditional formatting)
我正在寻找一种方法，通过 VBA 代码 但不是 通过应用一些条件格式来将色标应用于一组单元格...我想要将它们应用为静态颜色 (InteriorColor)
我搜索了很多 excel 网站，google 和 Whosebug，但一无所获:(
对于我的情况，如果你看下图：
你可以看到我给了它一个色标，在这个例子中，虽然我已经通过条件格式完成了色标。我想通过 VBA 创建色标，但它必须避免使用条件格式 ，我想为单元格分配内部颜色，以便颜色是静态的，使它们可见在所有移动 excel 观众上，速度更快，即使我要删除任何 numbers/rows.
也不会改变
这里有一些示例数据只需将其保存在 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 做过这个。
也许这就是您要找的：
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 的即时 window 中，执行 ?ActiveCell.Interior.Color 以获取您在步骤 1 中应用的内部颜色的颜色编号。
祝你好运。
以下函数 CalcColorScale 将 return 给定任意两种颜色的颜色，scale.The 比例是当前数据相对于数据范围的值。例如如果您的数据是从 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
假设：
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
我找到了正确答案，其实很简单。您所要做的就是添加条件格式，然后将 .Interior.Color 设置为与 .DisplayFormat.Interior.Color 相同的值，然后删除条件格式。
这将完全按照主 post 中的要求进行；如果您想将其作为后备方案，则不要删除条件格式。
' 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
希望这对以后的人有所帮助。
您始终可以使用 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
以上答案应该有效。不过，颜色与 Excel...
不同
要重新创建与 Excel 颜色格式完全相同的内容，并且在代码中更直接一些：
rgb(cr,cg,cb)
color1: 红色 - 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
我正在寻找一种方法，通过 VBA 代码 但不是 通过应用一些条件格式来将色标应用于一组单元格...我想要将它们应用为静态颜色 (InteriorColor)
我搜索了很多 excel 网站，google 和 Whosebug，但一无所获:(
对于我的情况，如果你看下图：
你可以看到我给了它一个色标，在这个例子中，虽然我已经通过条件格式完成了色标。我想通过 VBA 创建色标，但它必须避免使用条件格式 ，我想为单元格分配内部颜色，以便颜色是静态的，使它们可见在所有移动 excel 观众上，速度更快，即使我要删除任何 numbers/rows.
也不会改变这里有一些示例数据只需将其保存在 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 做过这个。
也许这就是您要找的：
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 的即时 window 中，执行
?ActiveCell.Interior.Color以获取您在步骤 1 中应用的内部颜色的颜色编号。
祝你好运。
以下函数 CalcColorScale 将 return 给定任意两种颜色的颜色，scale.The 比例是当前数据相对于数据范围的值。例如如果您的数据是从 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
假设：
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
我找到了正确答案，其实很简单。您所要做的就是添加条件格式，然后将 .Interior.Color 设置为与 .DisplayFormat.Interior.Color 相同的值，然后删除条件格式。
这将完全按照主 post 中的要求进行；如果您想将其作为后备方案，则不要删除条件格式。
' 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
希望这对以后的人有所帮助。
您始终可以使用 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
以上答案应该有效。不过，颜色与 Excel...
不同要重新创建与 Excel 颜色格式完全相同的内容，并且在代码中更直接一些：
rgb(cr,cg,cb)
color1: 红色 - 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