AW: VBA in Tabelle3 ausführen bei Änderung Tabelle 1
08.06.2016 12:19:22
TW
Danke für die Rückmeldung! Klar, sehr gerne. Der ist etwas länger:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim col
Dim ones, zeros, nth
ones = 0
zeros = 0
nth = 0
For intRow = 7 To 18
If Worksheets("Ergebnis").Cells(intRow, 2) = "0" Then
zeros = zeros + 1
ElseIf Worksheets("Ergebnis").Cells(intRow, 2) = "1" Then
ones = ones + 1
ElseIf Worksheets("Ergebnis").Cells(intRow, 2) = "" Then
nth = nth + 1
End If
Next intRow
'MsgBox zeros
'MsgBox ones
'MsgBox nth
For zero = 1 To zeros
ActiveSheet.Shapes.Range(Array("Thema" & CStr(zero))).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Solid
End With
Next zero
For one = 1 To ones
ActiveSheet.Shapes.Range(Array("Thema" & CStr(zeros + one))).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(200, 200, 200)
.Transparency = 0
.Solid
End With
Next one
If nth > 0 Then
For nths = 1 To nth
ActiveSheet.Shapes.Range(Array("Thema" & CStr(zeros + ones + nths))).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(200, 200, 200)
.Transparency = 0
.Solid
End With
Next nths
End If
' grün wäre (146, 208, 80)
'Kreis
If CStr(Range("B20")) 0.4 And CStr(Range("B20")) 0.7 Then
col = RGB(146, 208, 80)
End If
ActiveSheet.Shapes.Range(Array("Kreis")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = col
.Transparency = 0
.Solid
End With
Range("B25").Select
End Sub