Sub KTFAbisC()
'
' A1 A1 (Abgerufener Wert in Zelle I1)
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
Da tritt bei mir ein Laufzeitfehler im letzten Abschnitt auf, bei With sh.ShapeRange.