自定义图形自动变色

cfsusu

想做一个区域数据色斑图，根据地图手工绘制自定义图形，如何实现图形颜色随着数值变化而变化？共有16个区域，Excel图形颜色不能像单元格自定义格式那样设置，只能通过VBA实现吧？请教高手帮助。

vbee

自定义图形自动变色VBA

剑指E

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Dim arr(1 To 7), brr(1 To 7), a$, n&, i&, r&
    If Target.Column = 5 And Target.Row > 4 Then
        arr(1) = 0
        brr(1) = Cells(3, "t").Interior.Color
        For i = 2 To 7
            a = Cells(i + 1, "u")
            n = InStr(a, "-") + InStr(a, "<")
            arr(i) = Val(Mid(a, n + 1, 15))
            brr(i) = Cells(i + 2, "t").Interior.Color
        Next
        For i = 5 To Cells(Rows.Count, 3).End(3).Row
            Me.Shapes(Cells(i, 3).Value).Select
            If Err Then GoTo xxx
            n = Application.Lookup(Cells(i, 5), arr, brr)
            r = n Mod 256
            g = n \ 256 Mod 256
            b = n \ 256 \ 256 Mod 256
            Selection.ShapeRange.Fill.ForeColor.RGB = RGB(r, g, b)
xxx:             Err.Clear
        Next
    End If
[a1].Select
End Sub

cfsusu

vbee 发表于 2022-6-8 15:27
自定义图形自动变色VBA

非常感谢！

cfsusu

NIBABASHIWO 发表于 2022-6-8 16:01
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Dim arr(1 To 7),  ...

非常感谢！

cfsusu

补充一个问题：这些数据是通过公式引用其它表的值，不是手工输入的数据图形颜色就不变，怎么触发它呢？

cfsusu

NIBABASHIWO 发表于 2022-6-8 16:01
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Dim arr(1 To 7),  ...

补充一个问题：这些数据是通过公式引用其它表的值，不是手工输入的数据图形颜色就不变，怎么触发它呢？