Excel VBA形状颜色在标准上更改

时间：2016-06-16 10:46:48

标签： excel vba excel-vba colors shape

在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倍但具有不同的值。每当我必须修改它或添加新区域时，这是一个真正的痛苦。

2 个答案:

答案 0 :(得分：0)

我会创建一个小子像：

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)

替换重复的代码。

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

答案 1 :(得分：0)

一些事情：

  1. 由于值和相应的颜色都相同，您可以创建另一个子，为每个形状执行此颜色更改。然后，您可以使用call一次又一次地使用不同的变量或对象（如形状）执行此操作。
  2. 使用If
    3. 可以使多个连续Else If语句更清晰
  3. 使用With语句可以减少复制。
  4. 在使用If Rng.Value = "1"的代码中，请注意数据类型。通过将数字1括在语音标记中，将其作为字符串与Rng单元格的值进行比较。看起来你在这里遇到了一个问题，但是你的好习惯是明确你的类型。

    5. 把这些放在一起，看看这样的事情：

    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
相关问题
最新问题