vba 在 Excel 2010 中按范围内的绝对值为单元格着色

Color cells by absolute value in a range in Excel 2010

提问by HotDogCannon

I'm looking to color a table of values in Excel 2010 by their absolute value. Basically, if I have the table:

我希望通过绝对值为 Excel 2010 中的值表着色。基本上，如果我有桌子：

...the cells are colored by the cell's raw value. What I would like to do is color by the cell's absolutevalue, so with the cell coloring of this table:

...单元格由单元格的原始值着色。我想做的是按单元格的绝对值着色，因此使用此表的单元格着色：

...but with the values of the first table (the real values). Any ideas on how one might do this? Through the GUI or with VBA?

...但使用第一个表的值（实际值）。关于如何做到这一点的任何想法？通过 GUI 还是使用 VBA？

采纳答案by DHerls

I don't think that there is any way to do this with three colors (red, yellow, green), but you can do it with two colors (for example yellow and green). Simply make the color for the low value and the color for the high value the same. That way, the cells with the lower absolute value will have the middle color and cells with the higher absolute value will have the other color.

我不认为有任何方法可以用三种颜色（红色、黄色、绿色）来做到这一点，但你可以用两种颜色（例如黄色和绿色）来做到这一点。简单地使低值的颜色和高值的颜色相同。这样，绝对值较低的单元格将具有中间颜色，而绝对值较高的单元格将具有另一种颜色。

• Select Your data
• Conditional Formatting
• Color Scale
• More Rules
• Select "3-Point Scale" under Format Style
• Change the colors so that the Maximum and Minimum colors are the same

• 选择您的数据
• 条件格式
• 色阶
• 更多规则
• 在格式样式下选择“3-Point Scale”
• 更改颜色，使最大和最小颜色相同

回答by scottpjohnson

Here is my solution to this problem. The conditional format formula reads

这是我对这个问题的解决方案。条件格式公式为

=AND(ABS(B3)>0,ABS(B3)<=500) 

for the darkest green, the scale changes to 500 to 1000, 1000 to 1500, and finally 1500 to 2000 for the red band.

对于最深的绿色，比例变为 500 到 1000、1000 到 1500，最后是红色带的 1500 到 2000。

Conditional Formats

条件格式

Color Scale Values

色阶值

Here is a picture of the dataset that I used to test these conditional formats:

这是我用来测试这些条件格式的数据集的图片：

回答by barryleajo

A variation on this simple conditional formatting illustration may work for you.

这个简单的条件格式图的变体可能适合你。

Highlight the whole of the data range (you need the top LH cell to be the anchor for relative addressing) and enter the Formula: in 'relative notation' i.e. cell references without the dollar signs. You also have to consider the order of the rules.

突出显示整个数据范围（您需要顶部的 LH 单元格作为相对寻址的锚点）并输入公式：在“相对符号”中，即不带美元符号的单元格引用。您还必须考虑规则的顺序。

The uppermost formula is obscured but reads =(ABS(B3)>39) * (ABS(B3)<41)Note that the * symbol applies an AND operation.

最上面的公式是模糊的，但读取 =(ABS(B3)>39) * (ABS(B3)<41)注意 * 符号适用于 AND 运算。

回答by andrew

Ok, I have a solution that works with 3 color conditioning. Basically you supply a region to my code. It then creates two ranges, one of neg numbers and one of positive ones. It then applies conditional formatting

好的，我有一个适用于 3 色调节的解决方案。基本上你为我的代码提供一个区域。然后它创建两个范围，一个是负数，一个是正数。然后应用条件格式

red-low yellow-mid green-high to the positive range and

红低黄中绿高到正范围和

red-high yellow-mid green-low to the negative range.

红-高黄-中绿-低到负范围。

It was a quick solution so its sloppy and not robust (for instance it only works in columns A-Z because of a lazy ascii conversion for column numbers), but it works. (i'd post a pic but I don't have enough points)

这是一个快速的解决方案，因此它草率且不健壮（例如，由于列号的惰性 ascii 转换，它仅适用于列 AZ），但它有效。（我会发一张照片，但我没有足够的积分）

---------------------edit-------------------------------

- - - - - - - - - - -编辑 - - - - - - - - - - - - - - ---

@pnuts is right, unless the data is symmetric this solution wont work as is. so with that in mind I came up with a new solution. First I will explain the general idea, then basically just dump the code, if you understand the logic the code should be fairly clear. It is a rather involved solution for such a seemingly simple problem, but isn't that always the way? :-P

@pnuts 是对的，除非数据是对称的，否则此解决方案将无法按原样工作。所以考虑到这一点，我想出了一个新的解决方案。先解释一下大体思路，然后基本上就是转储代码，如果你理解逻辑，代码应该是相当清晰的。对于这样一个看似简单的问题，这是一个相当复杂的解决方案，但不总是这样吗？:-P

We are still using the basic idea of the original code, create a negative range and apply colorscale to it, then create a positive range and apply the inverted color scale to it. As seen below

我们仍然使用原始代码的基本思想，创建一个负范围并对其应用色阶，然后创建一个正范围并对其应用反转色阶。如下所示

Negative ........... 0 ................ positive

负 ..................... 0 ... 正

green yellow red | red yellow green

绿色黄色红色| 红黄绿

So with our skewed data data_set={-1,-1,-2,-2,-2,-2,-3,-4,1,5,8,13}what I do is mirror the the extreme value. In this case 13, so now data_set={-13,-1,-1,-2,-2,-2,-2,-3,-4,1,5,8,13}Notice the additional -13element. I assume you have a button to enact this macro so I store the extra -13in a cell that is underneath the button so even though its there it isn't visible (yeah I know they can move the button etc, but it was the easiest thing I could think of)

因此，对于我们的倾斜数据data_set={-1,-1,-2,-2,-2,-2,-3,-4,1,5,8,13}我所做的是镜像极值。在本例中为 13，所以现在data_set={-13,-1,-1,-2,-2,-2,-2,-3,-4,1,5,8,13}注意附加的-13元素。我假设你有一个按钮来执行这个宏，所以我将额外的-13存储在按钮下方的单元格中，所以即使它在那里也不可见（是的，我知道他们可以移动按钮等，但它是我能想到的最简单的事情）

Well that's all well and good green maps to 13 AND -13 but the color gradient is based on percentiles (in fact the color bar code uses the 50th percentile to determine the midpoint, or in our case where the yellow section is)

嗯，这一切都很好，绿色映射到 13 和 -13，但颜色渐变基于百分位数（实际上，颜色条码使用第 50 个百分位数来确定中点，或者在我们的情况下，黄色部分是）

Selection.FormatConditions(1).ColorScaleCriteria(2).Value = 50

so with our distribution {-13,-1,-1,-2,-2,-2,-2,-3,-4,1,5,8,13} we could start seeing the yellow in the positive range around the number 8.5 Since 8.5 is 50th percentile. but in the neg range (even if we add a mirrored -13) the 50th percentile is -2, so our yellow in the negative range would start at 2!! Hardly ideal. just like pnuts mentioned, but we are getting closer. if you have fairly symmetric data this issue won't be present, but again we are looking at worst case of skewed datasets

所以通过我们的分布 {-13,-1,-1,-2,-2,-2,-2,-3,-4,1,5,8,13} 我们可以开始在正范围内看到黄色围绕数字 8.5 因为 8.5 是第 50 个百分位数。但是在负值范围内（即使我们添加镜像 -13），第 50 个百分位数是 -2，因此负值范围内的黄色将从 2 开始！！不太理想。就像 pnuts 提到的那样，但我们越来越近了。如果您有相当对称的数据，则不会出现此问题，但我们再次查看偏斜数据集的最坏情况

What I did next is statistically match the midpoints....or at least their colors. So since our extreme value (13) is in the positive range we leave the yellow at the 50th percentile and try to mirror it to the negative range by changing what percentile the yellow color appears at (if the negative range had the extreme value we would leave the yellow at that 50th percentile and try to mirror it to the positive range). That means in our negative range we want to shift our yellow (50th percentile) from -2 to a number around -8.5 so it matches the positive range. I wrote a function called Function iGetPercentileFromNumber(my_range As Range, num_to_find As Double)That does just that! More Specifically it takes a range and reads the values into an array. It then adds num_to_findto the array and figures out what percentile num_to_findbelongs to as an integer 0-100 (hence the iin the function name). Again using our example data we would call something like

我接下来要做的是在统计上匹配中点……或者至少是它们的颜色。因此，由于我们的极值 (13) 在正值范围内，我们将黄色保留在第 50 个百分位，并尝试通过更改黄色出现的百分位将其镜像到负值范围（如果负值范围具有极值，我们将将黄色留在第 50 个百分位数并尝试将其镜像到正范围）。这意味着在我们的负范围内，我们希望将黄色（第 50 个百分位数）从 -2 移动到 -8.5 左右的数字，以便与正范围相匹配。我写了一个名为Function iGetPercentileFromNumber(my_range As Range, num_to_find As Double)That的函数 就是这样做的！更具体地说，它需要一个范围并将值读入一个数组。然后它添加num_to_find到数组并计算出num_to_find属于哪个百分位数作为i整数 0-100（因此函数名中的i）。再次使用我们的示例数据，我们会调用类似的东西

imidcolorpercentile = iGetPercentileFromNumber(negrange with extra element -13, -8.5)

Where the -8.5 is the negative(50th percentile number of positive range = 8.5). Don't worry the code automatically supplies the ranges and the numbers, this is just for your understanding. The function would add -8.5 to our array of negative values {-13,-1,-1,-2,-2,-2,-2,-3,-4,-8.5}then figure out what percentile it is.

其中 -8.5 是负数（正范围的第 50 个百分位数 = 8.5）。不要担心代码会自动提供范围和数字，这只是为了您的理解。该函数会将 -8.5 添加到我们的负值数组{-13,-1,-1,-2,-2,-2,-2,-3,-4,-8.5}然后找出它是哪个百分位数.

Now we take that percentile and pass it in as the midpoint for our negrange conditional formatting. so we changed the yellow from 50th percentile

现在我们取那个百分位数并将它作为我们的 negrange 条件格式的中点。所以我们从第 50 个百分位改变了黄色

Selection.FormatConditions(1).ColorScaleCriteria(2).Value = 50

to our new value

到我们的新价值

Selection.FormatConditions(1).ColorScaleCriteria(2).Value = imidcolorpercentile 'was 50

which now deskewed the colors!! we have basically created a symmetric in appearance color bar. Even if our numbers are far from symmetric.

现在对颜色进行了校正！！我们基本上创建了一个外观对称的颜色条。即使我们的数字远非对称。

Ok, I know that was a TON to read and digest. but here are the main takeaways this code - uses full 3-color conditional formatting (not simply setting the two extreme colors the same to look like abs value) - creates symmetric color ranges by using a obstructed cell (say under a button) to hold the extreme values - uses statistical analysis to match the color gradients even in skewed data sets

好的，我知道这是一个需要阅读和消化的 TON。但这里是这段代码的主要内容 - 使用完整的 3 色条件格式（不是简单地将两种极端颜色设置为相同以看起来像 abs 值） - 通过使用受阻单元格（例如在按钮下）来创建对称的颜色范围极值 - 即使在倾斜的数据集中，也使用统计分析来匹配颜色渐变

both steps are necessary and neither one on its own is sufficient to create a true mirror color scale

这两个步骤都是必要的，单独一个步骤都不足以创建真正的镜面色标

Since this solution requires statistical analysis of the data set, you would need to run it again any time you changed a number (which was actually the case before, I just never said it)

由于此解决方案需要对数据集进行统计分析，因此每次更改数字时都需要再次运行它（实际上以前就是这种情况，我只是从未说过）

and now the code. Put it in vba or some other highlighting program. It is nearly impossible to read as is ..... takes deep breath

现在是代码。把它放在 vba 或其他一些高亮程序中。几乎不可能按原样阅读.....深呼吸

Sub main()
    Dim Rng As Range
    Dim Cell_under_button As String

    Set Rng = Range("A1:H10") 'change me!!!!!!!
    Cell_under_button = "A15"

    Call AbsoluteValColorBars(Rng, Cell_under_button)

End Sub

Function iGetPercentileFromNumber(my_range As Range, num_to_find As Double)
    If (my_range.Count <= 0) Then
        Exit Function
    End If

    Dim dval_arr() As Double
    'this is one bigger than the range becasue we will add "num_to_find" to it
    ReDim dval_arr(my_range.Count + 1)
    Dim icurr_idx As Integer
    Dim ipos_num As Integer

    icurr_idx = 0

    'creates array of all the numbers in your range
    For Each cell In my_range
        dval_arr(icurr_idx) = cell.Value
        icurr_idx = icurr_idx + 1
    Next

    'adds the number we are searching for to the array
    dval_arr(icurr_idx) = num_to_find

    'sorts array in descending order
    dval_arr = BubbleSrt(dval_arr, False)

    'if match_type is 0, MATCH finds an exact match
    ipos_exact = Application.Match(CLng(num_to_find), dval_arr, 0)

    'there is a runtime error that can crop up when num_to_find isn't formated as long
    'so we converted it, if it was a double we may not find an exact match so ipos_Exact
    'may fail. now we have to find the closest numbers below or above clong(num_to_find)
    'If match_type is -1, MATCH finds the value <= num_to_find
    ipos_small = Application.Match(CLng(num_to_find), dval_arr, -1)

    If (IsError(ipos_small)) Then
        Exit Function
    End If

    'sorts array in ascending order
    dval_arr = BubbleSrt(dval_arr, True)

    'now we find the index of our  mid color point
    'If match_type is 1, MATCH finds the value >= num_to_find
    ipos_large = Application.Match(CLng(num_to_find), dval_arr, 1)

    If (IsError(ipos_large)) Then
        Exit Function
    End If

    'barring any crazy errors descending order = reverse order (ascending) so
    ipos_small = UBound(dval_arr) - ipos_small

    'to minimize color error we pick the value closest to num_to_find
    If Not (IsError(ipos_exact)) Then
        'barring any crazy errors descending order = reverse order (ascending) so
        'since the index was WRT descending subtract that from the length to get ascending
        ipos_num = UBound(dval_arr) - ipos_exact
    Else
        If (Abs(dval_arr(ipos_large) - num_to_find) < Abs(dval_arr(ipos_small) - num_to_find)) Then
            ipos_num = ipos_large
        Else
            ipos_num = ipos_small
        End If
    End If

    'gets the percentile as an integer value 0-100
    iGetPercentileFromNumber = Round(CDbl(ipos_num) / my_range.Count * 100)
End Function

'fairly well known algorithm doesn't need muxh explanation
Public Function BubbleSrt(ArrayIn, Ascending As Boolean)
    Dim SrtTemp As Variant
    Dim i As Long
    Dim j As Long


    If Ascending = True Then
        For i = LBound(ArrayIn) To UBound(ArrayIn)
             For j = i + 1 To UBound(ArrayIn)
                 If ArrayIn(i) > ArrayIn(j) Then
                     SrtTemp = ArrayIn(j)
                     ArrayIn(j) = ArrayIn(i)
                     ArrayIn(i) = SrtTemp
                 End If
             Next j
         Next i
    Else
        For i = LBound(ArrayIn) To UBound(ArrayIn)
             For j = i + 1 To UBound(ArrayIn)
                 If ArrayIn(i) < ArrayIn(j) Then
                     SrtTemp = ArrayIn(j)
                     ArrayIn(j) = ArrayIn(i)
                     ArrayIn(i) = SrtTemp
                 End If
             Next j
         Next i
    End If

    BubbleSrt = ArrayIn
End Function

Sub AbsoluteValColorBars(Rng As Range, Cell_under_button As String)
    negrange = ""
    posrange = ""

    'deletes existing rules
    Rng.FormatConditions.Delete

    'makes a negative and positive range
    For Each cell In Rng
        If cell.Value < 0 Then
            ' im certain there is a better way to get the column character
            negrange = negrange & Chr(cell.Column + 64) & cell.Row & ","
        Else
            ' im certain there is a better way to get the column character
            posrange = posrange & Chr(cell.Column + 64) & cell.Row & ","
        End If
    Next cell

    'removes trailing comma
    If Len(negrange) > 0 Then
        negrange = Left(negrange, Len(negrange) - 1)
    End If

    If Len(posrange) > 0 Then
        posrange = Left(posrange, Len(posrange) - 1)
    End If

    'finds the data extrema
    most_pos = WorksheetFunction.Max(Range(posrange))
    most_neg = WorksheetFunction.Min(Range(negrange))

    'initial values
    neg_range_percentile = 50
    pos_range_percentile = 50

    'if the negative range has the most extreme value
    If (most_pos + most_neg < 0) Then
        'put the corresponding positive number in our obstructed cell
        Range(Cell_under_button).Value = -1 * most_neg
        'and add it to the positive range, to reskew the data
        posrange = posrange & "," & Cell_under_button

        'gets the 50th percentile number from neg range and tries to mirror it in pos range
        'this should statistically skew the data
        the_num = WorksheetFunction.Percentile_Inc(Range(negrange), 0.5)
        pos_range_percentile = iGetPercentileFromNumber(Range(posrange), -1 * the_num)
    Else
        'put the corresponding negative number in our obstructed cell
        Range(Cell_under_button).Value = -1 * most_pos
        'and add it to the positive range, to reskew the data
        negrange = negrange & "," & Cell_under_button

        'gets the 50th percentile number from pos range and tries to mirror it in neg range
        'this should statistically skew the data
        the_num = WorksheetFunction.Percentile_Inc(Range(posrange), 0.5)
        neg_range_percentile = iGetPercentileFromNumber(Range(negrange), -1 * the_num)
    End If

    'low red high green for positive range
    Call addColorBar(posrange, False, pos_range_percentile)

     'high red low green for negative range
    Call addColorBar(negrange, True, neg_range_percentile)

End Sub
Sub addColorBar(my_range, binverted, imidcolorpercentile)
    If (binverted) Then
        'ai -> array ints
        adcolor = Array(8109667, 8711167, 7039480)
        '               green  , yellow , red
    Else
        adcolor = Array(7039480, 8711167, 8109667)
        '               red    , yellow , greeb
    End If

    Range(my_range).Select

     'these were just found using the record macro feature
    Selection.FormatConditions.AddColorScale ColorScaleType:=3
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority

    'assigns a color for the lowest values in the range
    Selection.FormatConditions(1).ColorScaleCriteria(1).Type = _
        xlConditionValueLowestValue
    With Selection.FormatConditions(1).ColorScaleCriteria(1).FormatColor
        .Color = adcolor(0)
        .TintAndShade = 0
    End With

    'assigns color to... midpoint of range
    Selection.FormatConditions(1).ColorScaleCriteria(2).Type = _
        xlConditionValuePercentile
    Selection.FormatConditions(1).ColorScaleCriteria(2).Value = imidcolorpercentile 'originally 50
    With Selection.FormatConditions(1).ColorScaleCriteria(2).FormatColor
        .Color = adcolor(1)
        .TintAndShade = 0
    End With

    'assigns colors to highest values in the range
    Selection.FormatConditions(1).ColorScaleCriteria(3).Type = _
        xlConditionValueHighestValue
    With Selection.FormatConditions(1).ColorScaleCriteria(3).FormatColor
        .Color = adcolor(2)
        .TintAndShade = 0
    End With
End Sub

回答by Clif

I am going to borrow heavily from the answer of @barryleajo (won't hurt my feelings if you select that answer). As was stated in that answer the order of the conditional formatting is the key, start with the smallest absolute values and work your way up. The difference between that answer and this one is that there is no need to use an "and" statement, since the OP seems to indicate that all values within a certain range of absolute value should receive the same color format. Here is a small example:

我将从@barryleajo 的答案中大量借鉴（如果您选择该答案，不会伤害我的感情）。正如该答案中所述，条件格式的顺序是关键，从最小的绝对值开始，然后逐步向上。该答案与此答案之间的区别在于不需要使用“和”语句，因为 OP 似乎表明绝对值一定范围内的所有值都应接收相同的颜色格式。这是一个小例子：