Excel VBA 根据标准更改形状颜色

Question

A 在 excel 文件中创建了一个简单的仪表板，显示了在单独的 sheet 上输入的值。根据输入的值，一旦宏被激活，形状（正方形）的颜色就会发生变化。

我是 excel VBA 的新人，我设法让它工作，但我的代码确实很长，我相信它可以简化。请参阅以下示例：

Sub ScoreCard_Icon()

Dim Rng As Range
Dim ShapeName As String
Dim SHP As Shape

WebVisits = "AS_1"
BounceRate = "AS_2"
SEOVisits = "AS_3"
PPCImpressionsShare = "AS_4"
MediaImpression = "AS_5"
FacebookReach = "AS_6"
YoutubeViews = "AS_7"
RndR = "AS_8"
EShare = "AS_9"
ENOS = "AS_10"
EComSndS = "AS_11"
CARSScore = "AS_12"

Set Rng = ThisWorkbook.Worksheets("Rectangle test").Range("N53")
Set SHP = Rng.Parent.Shapes(WebVisits)

If Rng.Value = "0" Then
SHP.Fill.ForeColor.RGB = RGB(246, 0, 0)
End If

If Rng.Value = "1" Then
SHP.Fill.ForeColor.RGB = RGB(255, 153, 51)
End If

If Rng.Value = "2" Then
SHP.Fill.ForeColor.RGB = RGB(223, 223, 19)
End If

If Rng.Value = "3" Then
SHP.Fill.ForeColor.RGB = RGB(102, 255, 51)
End If

Set Rng = ThisWorkbook.Worksheets("Rectangle test").Range("N54")
Set SHP = Rng.Parent.Shapes(BounceRate)

If Rng.Value = "0" Then
SHP.Fill.ForeColor.RGB = RGB(246, 0, 0)
End If

If Rng.Value = "1" Then
SHP.Fill.ForeColor.RGB = RGB(255, 153, 51)
End If

If Rng.Value = "2" Then
SHP.Fill.ForeColor.RGB = RGB(223, 223, 19)
End If

If Rng.Value = "3" Then
SHP.Fill.ForeColor.RGB = RGB(102, 255, 51)
End If


Set Rng = ThisWorkbook.Worksheets("Rectangle test").Range("N55")
Set SHP = Rng.Parent.Shapes(SEOVisits)

If Rng.Value = "0" Then
SHP.Fill.ForeColor.RGB = RGB(246, 0, 0)
End If

If Rng.Value = "1" Then
SHP.Fill.ForeColor.RGB = RGB(255, 153, 51)
End If

If Rng.Value = "2" Then
SHP.Fill.ForeColor.RGB = RGB(223, 223, 19)
End If

If Rng.Value = "3" Then
SHP.Fill.ForeColor.RGB = RGB(102, 255, 51)
End If



Set Rng = ThisWorkbook.Worksheets("Rectangle test").Range("N56")
Set SHP = Rng.Parent.Shapes(PPCImpressionsShare)

If Rng.Value = "0" Then
SHP.Fill.ForeColor.RGB = RGB(246, 0, 0)
End If

If Rng.Value = "1" Then
SHP.Fill.ForeColor.RGB = RGB(255, 153, 51)
End If

If Rng.Value = "2" Then
SHP.Fill.ForeColor.RGB = RGB(223, 223, 19)
End If

If Rng.Value = "3" Then
SHP.Fill.ForeColor.RGB = RGB(102, 255, 51)
End If



Set Rng = ThisWorkbook.Worksheets("Rectangle test").Range("N57")
Set SHP = Rng.Parent.Shapes(MediaImpression)

If Rng.Value = "0" Then
SHP.Fill.ForeColor.RGB = RGB(246, 0, 0)
End If

If Rng.Value = "1" Then
SHP.Fill.ForeColor.RGB = RGB(255, 153, 51)
End If

If Rng.Value = "2" Then
SHP.Fill.ForeColor.RGB = RGB(223, 223, 19)
End If

If Rng.Value = "3" Then
SHP.Fill.ForeColor.RGB = RGB(102, 255, 51)
End If



Set Rng = ThisWorkbook.Worksheets("Rectangle test").Range("N58")
Set SHP = Rng.Parent.Shapes(FacebookReach)

If Rng.Value = "0" Then
SHP.Fill.ForeColor.RGB = RGB(246, 0, 0)
End If

If Rng.Value = "1" Then
SHP.Fill.ForeColor.RGB = RGB(255, 153, 51)
End If

If Rng.Value = "2" Then
SHP.Fill.ForeColor.RGB = RGB(223, 223, 19)
End If

If Rng.Value = "3" Then
SHP.Fill.ForeColor.RGB = RGB(102, 255, 51)
End If



Set Rng = ThisWorkbook.Worksheets("Rectangle test").Range("N59")
Set SHP = Rng.Parent.Shapes(YoutubeViews)

If Rng.Value = "0" Then
SHP.Fill.ForeColor.RGB = RGB(246, 0, 0)
End If

If Rng.Value = "1" Then
SHP.Fill.ForeColor.RGB = RGB(255, 153, 51)
End If

If Rng.Value = "2" Then
SHP.Fill.ForeColor.RGB = RGB(223, 223, 19)
End If

If Rng.Value = "3" Then
SHP.Fill.ForeColor.RGB = RGB(102, 255, 51)
End If



Set Rng = ThisWorkbook.Worksheets("Rectangle test").Range("N60")
Set SHP = Rng.Parent.Shapes(RndR)

If Rng.Value = "0" Then
SHP.Fill.ForeColor.RGB = RGB(246, 0, 0)
End If

If Rng.Value = "1" Then
SHP.Fill.ForeColor.RGB = RGB(255, 153, 51)
End If

If Rng.Value = "2" Then
SHP.Fill.ForeColor.RGB = RGB(223, 223, 19)
End If

If Rng.Value = "3" Then
SHP.Fill.ForeColor.RGB = RGB(102, 255, 51)
End If



Set Rng = ThisWorkbook.Worksheets("Rectangle test").Range("N61")
Set SHP = Rng.Parent.Shapes(EShare)

If Rng.Value = "0" Then
SHP.Fill.ForeColor.RGB = RGB(246, 0, 0)
End If

If Rng.Value = "1" Then
SHP.Fill.ForeColor.RGB = RGB(255, 153, 51)
End If

If Rng.Value = "2" Then
SHP.Fill.ForeColor.RGB = RGB(223, 223, 19)
End If

If Rng.Value = "3" Then
SHP.Fill.ForeColor.RGB = RGB(102, 255, 51)
End If



Set Rng = ThisWorkbook.Worksheets("Rectangle test").Range("N62")
Set SHP = Rng.Parent.Shapes(ENOS)

If Rng.Value = "0" Then
SHP.Fill.ForeColor.RGB = RGB(246, 0, 0)
End If

If Rng.Value = "1" Then
SHP.Fill.ForeColor.RGB = RGB(255, 153, 51)
End If

If Rng.Value = "2" Then
SHP.Fill.ForeColor.RGB = RGB(223, 223, 19)
End If

If Rng.Value = "3" Then
SHP.Fill.ForeColor.RGB = RGB(102, 255, 51)
End If



Set Rng = ThisWorkbook.Worksheets("Rectangle test").Range("N63")
Set SHP = Rng.Parent.Shapes(EComSndS)

If Rng.Value = "0" Then
SHP.Fill.ForeColor.RGB = RGB(246, 0, 0)
End If

If Rng.Value = "1" Then
SHP.Fill.ForeColor.RGB = RGB(255, 153, 51)
End If

If Rng.Value = "2" Then
SHP.Fill.ForeColor.RGB = RGB(223, 223, 19)
End If

If Rng.Value = "3" Then
SHP.Fill.ForeColor.RGB = RGB(102, 255, 51)
End If



Set Rng = ThisWorkbook.Worksheets("Rectangle test").Range("N64")
Set SHP = Rng.Parent.Shapes(CARSScore)

If Rng.Value = "0" Then
SHP.Fill.ForeColor.RGB = RGB(246, 0, 0)
End If

If Rng.Value = "1" Then
SHP.Fill.ForeColor.RGB = RGB(255, 153, 51)
End If

If Rng.Value = "2" Then
SHP.Fill.ForeColor.RGB = RGB(223, 223, 19)
End If

If Rng.Value = "3" Then
SHP.Fill.ForeColor.RGB = RGB(102, 255, 51)
End If


End Sub

问题是我有 10 个不同的 sheet（反映不同区域的值）以相同的方式构建，因此是您在上面看到的代码的 10 倍，但具有不同的值。每当我必须修改它或添加新区域时，这真是一件痛苦的事。

Answer 1

我会创建一个像这样的小子：

Sub Kolor(R As Range, s As Shape)
    Dim v As String
    v = R.Value
    With s.Fill.ForeColor
        If v = "0" Then
            .RGB = RGB(246, 0, 0)
        End If

        If v = "1" Then
            .RGB = RGB(255, 153, 51)
        End If

        If v = "2" Then
            .RGB = RGB(223, 223, 19)
        End If

        If v = "3" Then
            .RGB = RGB(102, 255, 51)
        End If
    End With
End Sub

然后从ScoreCard_Icon() 像这样称呼它：

Call Kolor(Rng, SHP)

替换重复代码。

下一步可能是将范围和形状放在数组中并使用循环。

Answer 2

几件事：

由于值和相应的颜色都相同，您可以创建另一个子来为每个形状进行颜色更改。然后，您可以使用 call 使用不同的变量或对象（例如您的形状）一次又一次地执行此操作。
可以使用 Else If

If

使用 With 语句可以减少复制。
注意你的数据类型，在你的代码中你使用了 If Rng.Value = "1"。通过将数字 1 括在语音标记中，会将其作为字符串与 Rng 单元格的值进行比较。看起来你运行并没有遇到问题，但明确你的类型是个好习惯。

把这些放在一起，你会看到这样的东西：

Sub ScoreCard_Icon()

    Dim Rng As Range
    Dim ShapeName As String
    Dim SHP As Shape

    WebVisits = "AS_1"
    BounceRate = "AS_2"
    SEOVisits = "AS_3"
    PPCImpressionsShare = "AS_4"
    MediaImpression = "AS_5"
    FacebookReach = "AS_6"
    YoutubeViews = "AS_7"
    RndR = "AS_8"
    EShare = "AS_9"
    ENOS = "AS_10"
    EComSndS = "AS_11"
    CARSScore = "AS_12"

    With ThisWorkbook.Worksheets("Rectangle test")
        Call changeColor(.Range("N53").Value, .Shapes(WebVisits))
        Call changeColor(.Range("N54").Value, .Shapes(BounceRate))
        Call changeColor(.Range("N55").Value, .Shapes(SEOVisits))
        'etc...
    End With

End Sub


Sub changeColor(rngVal As Integer, SHP As Shape)
    With SHP
        If rngVal = 0 Then
            .Fill.ForeColor.RGB = RGB(246, 0, 0)
        ElseIf rngVal = 1 Then
            .Fill.ForeColor.RGB = RGB(255, 153, 51)
        ElseIf rngVal = 2 Then
            .Fill.ForeColor.RGB = RGB(223, 223, 19)
        ElseIf rngVal = 3 Then
            .Fill.ForeColor.RGB = RGB(102, 255, 51)
        End If
    End With
End Sub

Excel VBA 根据标准更改形状颜色

Excel VBA shape color changing on criteria

excel

vba

colors

shape