Изменение цвета формы VBA Excel

Создана простая панель управления в файле excel, отображающая значения, введенные на отдельном листе. В зависимости от введенных значений цвет формы (квадрат) меняется после активации макроса.Изменение цвета формы VBA 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 раз кода, который вы можете увидеть выше, но с разными значениями. Это настоящая боль в заднице, когда я должен ее модифицировать или добавлять новые регионы.

источник

2016-06-16 Samy Abouseda

Я не вижу вопрос, какая часть не работает? –

Если он работает, и вы ищете улучшения, попробуйте вместо codereview.stackexchange – Raystafarian

Несколько вещей:

качестве значений и соответствующих цветов все же вы можете создать еще один сабвуфер, чтобы сделать это изменение цвета для каждой формы. Затем вы можете использовать call для повторного выполнения этого действия с помощью разных переменных или объектов, таких как ваши фигуры.
Несколько последовательных If заявление может быть сделано чище с помощью Else If
Использования With операторов могут уменьшить репликацию.
Будьте осторожны с вашими типами данных, в коде, который вы использовали If Rng.Value = "1". Включение номера 1 в речевые метки будет сравнивать его как строку со значением вашей ячейки Rng. Кажется, вы не столкнулись с проблемой здесь, но ее хорошая практика должна быть явной с вашими типами.

Put это все вместе и ваш смотреть на что-то вроде этого:

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

источник

2016-06-16 11:28:50 Carrosive

Я хотел бы создать небольшой сабвуфер, как:

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)

заменить повторяющийся код.

Следующим шагом может быть размещение диапазонов и фигур в массивах и использование цикла.

источник

2016-06-16 11:11:08

Изменение цвета формы VBA Excel

ответ

Смежные вопросы