Hallo zusammen.
Vermutlich habe ich mich zu umständlich ausgedrückt:
Bei anhängender Datei wird das unten stehende Makro nicht bis in die letzten beiden Zeilen ausgeführt:
Dim RaBereich As Range, RaZelle As Range
' Bereich der Wirksamkeit
Set RaBereich = Range("D23:L52")
' noch mehr Bereiche
' Set RaBereich = Union(Range("C7:I26"), Range("L7:R26"), Range("U7:AA26"), Range("AD7:AJ26"))
' ab Vesion XP braucht der Schutz nicht aufgehoben werden
' Formatierung bei Schutz kann über Dialog Schutz eingestellt werden
' ActiveSheet.Unprotect ("Passwort")
For Each RaZelle In Range(Target.Address)
With Range(RaZelle.Address).Offset(0, 1)
If Not Intersect(RaZelle, RaBereich) Is Nothing Then
Select Case RaZelle.Value
Case "1"
.Interior.ColorIndex = 4
Case "2"
.Interior.ColorIndex = 35
Case "3"
.Interior.ColorIndex = 6
Case "4"
.Interior.ColorIndex = 38
Case "5"
.Interior.ColorIndex = 3
Case Else
.Interior.ColorIndex = xlNone
End Select
End If
End With
Next RaZelle
' ActiveSheet.protect ("Passwort")
Set RaBereich = Nothing
End Sub
Bei E51 und E52 sollten die Farben auch automatisch übernommen werden.
Wer kann mir da helfen?
https://www.herber.de/bbs/user/24090.xls