code funktioniert nicht mehr
19.11.2019 08:31:34
Torsten
ich versteh die Excel Welt nicht mehr. Mit unten stehendem Code will ich die Zellfarbe aendern je nach Eingabe. Dieser Code hat in der 2019 Version meines Urlaubsplaners auch wunderbar funktioniert und funktioniert auch immer noch. Jetzt habe ich die komplette Datei kopiert und in den Sheets lediglich die Datuemer veraendert auf 2020 fuer die neue Version fuer das naechste Jahr. Jetzt funktioniert dieser Code ploetzlich nicht mehr. Das einzige, was ausgefuehrt wird ist, dass die Buchstaben auf Grossschreibung geaendert werden. aber beim Setzen der Hintergrundfarbe bekomme ich jetzt den Laufzeitfehler 1004. Ich kapier nicht, warum. Kann mir jemand auf die Spruenge helfen?
Code:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim rngRange As Range, rngCell As Range
Set rngRange = Range("F10:AJ159")
For Each rngCell In Range(Target.Address)
If Not Intersect(rngCell, rngRange) Is Nothing Then
Select Case UCase(rngCell.Value)
Case "LL"
rngCell.Interior.ColorIndex = 4 ' green
rngCell.Font.ColorIndex = 1 ' black
Case "LL½"
rngCell.Interior.ColorIndex = 4 ' green
rngCell.Font.ColorIndex = 1 ' black
Case "UP"
rngCell.Interior.ColorIndex = 16 ' grey
rngCell.Font.ColorIndex = 2 ' black
Case "UP½"
rngCell.Interior.ColorIndex = 16 ' grey
rngCell.Font.ColorIndex = 1 ' black
Case "SL"
rngCell.Interior.ColorIndex = 3 ' red
rngCell.Font.ColorIndex = 1 ' black
Case "SL½"
rngCell.Interior.ColorIndex = 3 ' red
rngCell.Font.ColorIndex = 1 ' black
Case Else
rngCell.Interior.ColorIndex = 2 ' none
End Select
End If
Next rngCell
Set rngRange = Nothing
End Sub