使用顺序或发散色标根据数据为图表的每个点着色

Question

如何根据电子表格中的值为散点图上的各个点着色？例如，我如何创建以下图表：

x 数据在 U 列中，y 数据在 V 列中，颜色数据在 T 列中如何创建发散颜色图而不是连续颜色图？

Answer 1

GitHub 上的完整示例：https : //github.com/DanGolding/Scatter-plot-with-color-grading-in-Excel

如果您的颜色数据只有几个离散值，最简单的方法是将其绘制为不同的系列，如下所示。但是，如果您有顺序数据，则需要使用 VBA 循环遍历数据系列的每个点并更改其颜色。

使用宏编辑器，很容易找到更改单个标记颜色的代码。然后您可以修改它以适应循环。此代码稍后显示。现在的挑战是选择一个好的颜色映射。此答案提供了创建映射的代码，该映射是通过单个 RGB 通道的简单线性调制从一种颜色到另一种颜色的渐变。但是，我发现顺序数据更自然的映射是保持颜色的色调和饱和度不变，然后改变亮度/亮度通道。例如，这是 Excel 如何改变颜色选择器中的标准颜色：

幸运的是，您可以公开一个 API 函数，将 HLS 颜色空间转换为设置标记颜色所需的 RGB 颜色空间。为此，请将以下代码行添加到模块的顶部：

Public Declare PtrSafe Function ColorHLSToRGB Lib "shlwapi.dll" (ByVal wHue As Long, ByVal wLuminance As Long, ByVal wSaturation As Long) As Long

请注意，我PtrSafe在上面的行中添加了内容，因为这似乎使该函数适用于 32 位和 64 位版本的 Excel。

通过一些实验，我发现您不能使wLuminance通道高于，240因此我使用以下函数将我们的着色数据（问题中的 T 列）映射到范围从0到240：

Function normalize(datum As Variant, dataMin As Double, dataMax As Double) As Integer
    normalize = CInt(((datum - dataMin) / (dataMax-dataMin)) * 241)
End Function

为图表着色的最终代码是

Sub colourChartSequential()

    Dim data As Variant
    Dim dataMin As Double
    Dim dataMax As Double

    data = Range("T1:T50") 'Modify this as needed, probably to be more dynamic
    dataMin = WorksheetFunction.min(data) 'Note this doesn't work if your data are formatted as dates for some reason...
    dataMax = WorksheetFunction.max(data)

    With Worksheets("Sheet1").ChartObjects("Chart 1").Chart.FullSeriesCollection(1) 'Change "Chart 1" to the name of your chart

        Dim Count As Integer
        For Count = 1 To UBound(data)
             datum = data(Count, 1)
             .Points(Count).Format.Fill.BackColor.rgb = ColorHLSToRGB(161, normalize(datum, dataMin, dataMax), 220)
        Next Count

    End With

End Sub

请注意，我调用ColorHLSToRGB(161, normalize(datum, dataMin, dataMax), 220)的色调值为 ，161饱和度值为220。我从颜色选择器中获得了这些值，方法是从基色开始，然后选择更多颜色，然后将下拉列表（下面以红色突出显示）从 RGB 更改为 HSL。另请注意，右侧从黑色到蓝色再到白色的条形图是您仅通过改变亮度获得的颜色映射。

顺便说一下，如果你想针对不同的数据调整这个，我建议改变归一化函数的范围从 240 到 120（所以 240 代表低值，所以它是接近零的白色），然后将代码调整为这样的（请注意，代码假设数据存在分歧，0但您可以随时更改）：

Function normalizeDivergent(datum As Variant, dataMin As Double, dataMax As Double) As Integer
    normalizeDivergent = 240 - CInt(((datum - dataMin) / (dataMax - dataMin)) * 121)
End Function

Sub colourChartDivergent()

    Dim data As Variant
    Dim dataMin As Double
    Dim dataMax As Double

    Dim lastRow As Integer
    lastRow = Range("T1").End(xlDown).row
    data = Range("T1:T" & lastRow)
    dataMin = WorksheetFunction.min(data)
    dataMax = WorksheetFunction.max(data)

    dataMax = WorksheetFunction.max(dataMax, -dataMin)
    dataMin = 0

    With Worksheets("Sheet1").ChartObjects("Chart 1").Chart.FullSeriesCollection(1)

        Dim Count As Integer
        For Count = 1 To UBound(data)
             datum = data(Count, 1)

            If datum > 0 Then
                .Points(Count).Format.Fill.BackColor.rgb = ColorHLSToRGB(161, normalizeDivergent(datum, dataMin, dataMax), 220)
            Else
                .Points(Count).Format.Fill.BackColor.rgb = ColorHLSToRGB(0, normalizeDivergent(-datum, dataMin, dataMax), 220)
            End If
        Next Count

    End With

End Sub

产生类似的东西

编辑：

阅读这篇出色的文章后：http : //vis4.net/blog/posts/avoid-equidistant-hsv-colors/这让我找到了http://tools.medialab.sciences-po.fr/iwanthue/theory.php和https://vis4.net/blog/posts/mastering-multi-hued-color-scales/我意识到在 HSL 空间中进行插值也是有缺陷的。在 VBA 中转换为CIE L*a*b* / HCL 颜色空间，然后执行 vis4.net 建议的 Bezier 插值和亮度校正似乎太令人生畏了。所以我用他们很棒的工具来设计一个颜色图查找表：http : //gka.github.io/palettes/#diverging|c0=DarkRed,LightSalmon,white|c1=white,PaleTurquoise,MediumBlue|steps=255 |bez0=1|bez1=1|coL0=1|coL1=1希望这比我原来的 HSL 插值在感知上更线性。请注意，我尝试选择颜色，以便亮度图（颜色条下方的黑色对角线）大致对称，以便感知亮度映射到绝对值）

第一步是复制第一个十六进制数字块并将它们保存为文本文件：

然后在 Excel 中，我使用 DATA -> From Text 导入十六进制数字（空格分隔），将它们转置到 A 列，使用=MID(A1,2,6)B 列向下的公式清理它们，然后使用将 RGB 分量拆分为 C - E 列=HEX2DEC(LEFT(B1,2))红色通道、=HEX2DEC(MID(B1,3,2))蓝色通道和=HEX2DEC(RIGHT(B1,2))绿色通道的公式。

然后，我通过使用此 VBA 代码在 G 列中的单元格中着色来测试这些 RGB 值：

Sub makeColourBar()
    Dim row As Integer
    For row = 1 To 255
        Range("G" & row).Interior.color = rgb(Range("C" & row).Value, Range("D" & row).Value, Range("E" & row).Value)
    Next row
End Sub

这导致正确

现在将此颜色映射应用于 xy 散点图，我编写了此代码

Function normalizeLookUp(datum As Variant, dataMin As Double, dataMax As Double, n As Integer) As Integer
    normalizeLookUp = CInt(((datum - dataMin) / (dataMax - dataMin)) * (n - 1)) + 1
End Function

Sub colourChartLookUp()

    Dim data As Variant
    Dim dataMin As Double
    Dim dataMax As Double

    Dim lastRow As Integer
    lastRow = Range("H1").End(xlDown).row
    data = Range("H1:H" & lastRow)
    dataMin = WorksheetFunction.min(data)
    dataMax = WorksheetFunction.max(data)

    dataMax = WorksheetFunction.max(dataMax, -dataMin)
    dataMin = -dataMax

    With Worksheets("Colour Map").ChartObjects("Chart 1").Chart.FullSeriesCollection(1)

        Dim Count As Integer
        Dim colourRow As Integer
        For Count = 1 To UBound(data)
             datum = data(Count, 1)
                colourRow = normalizeLookUp(datum, dataMin, dataMax, 255)
                .Points(Count).Format.Fill.BackColor.rgb = rgb(Range("C" & colourRow).Value, Range("D" & colourRow).Value, Range("E" & colourRow).Value)
        Next Count

    End With

End Sub

这导致

缺点是您的颜色映射存储在您的一个工作表中（尽管您可以将其存储为 VBA 数组），但最终您应该获得一个在感知上统一的颜色映射，因此对解释数据更有用。

请注意，对于拼图的最后一部分，您可能需要阅读向图表添加颜色条。