Cambio de color de la forma de Excel VBA en los criterios

A creó un tablero de instrumentos simple en un file de Excel que muestra los valores ingresados ​​en una hoja separada. Dependiendo de los valores ingresados, el color de la forma (cuadrado) cambia una vez que se activa la macro.

Soy nuevo en Excel VBA y logré que funcione, pero mi código es muy largo para lo que hace y creo que podría simplificarse. Vea el ejemplo a continuación:

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 

El problema es que tengo 10 hojas diferentes (reflejando valores para diferentes regiones) comstackdas de la misma manera y, por lo tanto, 10 veces el código que puede ver arriba, pero con valores diferentes. Es un verdadero dolor en el culo cada vez que tengo que modificarlo o agregar nuevas regiones.

Unas pocas cosas:

  1. Como los valores y los colors correspondientes son todos iguales, podría crear otro sub para hacer este cambio de color para cada forma. A continuación, puede usar la call para realizar esta acción una y otra vez con diferentes variables u objects, como sus forms.
  2. Múltiples declaraciones secuenciales If pueden hacerse más limpias mediante Else If
  3. El uso de sentencias With puede networkingucir la replicación.
  4. Tenga cuidado con sus types de datos, en su código que ha utilizado If Rng.Value = "1" . Al encerrar el número 1 en las marcas de voz será compararlo como una cadena contra el valor de su celda Rng. No parece que haya encontrado un problema aquí, pero es una buena práctica ser explícito con sus types.

Pon todo esto junto y estás viendo algo como esto:

 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 

Crearía un pequeño sub como:

 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 

y luego desde ScoreCard_Icon() llámalo así:

 Call Kolor(Rng, SHP) 

para replace el código repetido.

El siguiente paso podría ser colocar los ranges y las forms en matrices y usar un bucle.