使用vba创建一个“颜色标尺”(避免条件格式)

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)

我正在寻找一种方法，通过VBA代码将颜色扩展到一组单元格，但不是通过应用一些条件格式…我想把它们作为静态颜色(InteriorColor)应用

I've searched plenty of excel sites, google and * and found nothing :(

我搜索了很多excel网站，谷歌和*，什么也没找到:

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中的数据:

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。

5 个解决方案

#1

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将返回给定任何两种颜色和刻度的颜色。scale是当前数据相对于数据范围的值。如果你的数据是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

#2

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，然后将interiorcolor设置为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 

#3

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:

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

1. Apply an interior color to a cell. Make sure the cell is selected.

   将内部颜色应用于单元格。确保选择了单元格。

2. In the VBE's Immediate window, execute ?ActiveCell.Interior.Color to get the color number for the interior color you've applied in Step 1.

   在VBE的即时窗口中，执行?ActiveCell.Interior。颜色为你在第一步中应用的内部颜色得到颜色数字。

Good luck.

祝你好运。

#4

assuming:

假设:

values in A1:A40.

值在A1:钠。

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

#5

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.Color to the same as what the .DisplayFormat.Interior.Color is and then delete the conditional formatting.

我已经找到了正确答案，其实相当简单。您所要做的就是添加条件格式，然后设置. interior。颜色与. displayformat.内部的颜色相同。颜色是然后删除条件格式。

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.

希望这能帮助未来的人。