Excel VBA形状颜色根据标准改变答案

【问题标题】：Excel VBA shape color changing on criteriaExcel VBA形状颜色根据标准改变
【发布时间】：2016-10-17 20:09:56
【问题描述】：

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

我是 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 个不同的工作表（反映不同区域的值）以相同的方式构建，因此是您在上面看到的代码的 10 倍，但具有不同的值。每当我必须修改它或添加新区域时，这真是让人头疼。

【问题讨论】：

我没有看到问题，哪个部分不起作用？
如果它有效并且您正在寻求改进，请尝试 codereview.stackexchange

标签： vba excel colors shape

【解决方案1】：

一些事情：

由于值和相应的颜色都相同，您可以创建另一个子来为每个形状进行颜色更改。然后，您可以使用 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

【讨论】：

【解决方案2】：

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

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)

替换重复的代码。

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

【讨论】：