Case Anwendung

Sub Neuer_Schichtplan()
Application.ScreenUpdating = False
Application.EnableEvents = False
If Application.InputBox("Bitte Passwort eingeben : ") = "test" Then
If MsgBox("Wollen Sie die Schichten einfügen ? Die alten Schichtpläne werden gelöscht.",  _
vbQuestion + vbYesNo, _
" Nachfrage Schichten einfügen !") = vbNo Then Exit Sub
'Jänner
Sheets("Jänner").Unprotect Password:="test"
Worksheets("Jänner").Range("C3:AH154").ClearContents
Worksheets("Jänner").Range("C3:AH154").ClearComments
Worksheets("Jänner").Range("C3:AH154").Font.ColorIndex = 0
Worksheets("Jänner").Range("C3:AH154").Interior.ColorIndex = xlNone
'Schichtplan
Worksheets("Schichtplan").Range("C6:K36").Copy
Worksheets("Jänner").Range("C500").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Worksheets("Jänner").Range("C541:AG692").Copy
Worksheets("Jänner").Range("C3").PasteSpecial Paste:=xlPasteValues, Transpose:=False
Worksheets("Jänner").Range("C3:AG154").Replace what:="0", Replacement:=""
Sheets("Jänner").Protect Password:="test"
MsgBox "Es wurden alle Schichten für das Jahr" & Chr(13) & Worksheets("Formel").Range("A1") & "  _
" & "eingefügt"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Sub Worksheet_Change(ByVal Target As Range)
Dim Kal_Bereich As Range, Kal_Cell As Range
Set Kal_Bereich = Range("C3:AI154")  'Bereich in dem was geändert wird
Set Kal_Bereich = Intersect(Kal_Bereich, Range(Target.Address))
ActiveSheet.Unprotect Password:="test"   'Blattschutz aus
If Kal_Bereich Is Nothing Then Exit Sub
For Each Kal_Cell In Kal_Bereich
With Range(Kal_Cell.Address, Kal_Cell.Offset(0, 0).Address)
Select Case UCase(Kal_Cell.Value) ' UMWANDLUNG DER Eingabe in Großbuchstaben für  _
Formatierung
Case "B= BEZAHLT FREI"
.Interior.ColorIndex = 7  'rosa
.Font.ColorIndex = 2 'weiß
Case Else
.Interior.ColorIndex = 2
.Font.ColorIndex = 0
End Select
End With
Next Kal_Cell
End Sub