Sub KTFAbisC()
checkvalues Range("I1"), "Oval 3"
checkvalues Range("I2"), "Oval 4"
checkvalues Range("I3"), "Oval 7"
checkvalues Range("I4"), "Oval 6"
checkvalues Range("I5"), "Oval 17"
checkvalues Range("I6"), "Oval 18"
End Sub
Sub checkvalues(rng As Range, shp As String)
Dim shpe As Shape
Set shpe = ActiveSheet.Shapes(shp)
Select Case rng.Value
Case 1: changeshape shpe, 0.8, 14.1732283465, 1.2
Case 0: changeshape shpe, 1, 24.1732283465, 1.5
Case 2: changeshape shpe, 0.65, 24.1732283465, 1.5
Case 3: changeshape shpe, 0.5, 30.1732283465, 1.5
Case Is >= 4: changeshape shpe, 0.4, 33.1732283465, 1.5
End Select
End Sub
Sub changeshape(sh As Shape, transp As Double, heigt As Double, weigt As Double)
With sh.ShapeRange
With .Fill
.Visible = msoFalse
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = transp
.Solid
End With
With .Line
.Visible = msoTrue
.Weight = weigt
.ForeColor.RGB = RGB(255, 0, 0)
End With
.LockAspectRatio = msoTrue
.Height = heigt
Range("H7").Select
End With
End Sub