Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
' oder EinfachClick
'
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim x As Byte, y As Byte
Dim Beginn As Date, Ende As Date
Dim txt As String, Grund As String
Dim Zeile As Long, dat As Long, Anzahl As Long, gAnzahl As Long
Select Case Target.Address
Case "$A$8", "$A$23", "$A$36"
Zeile = 8
Case "$A$9", "$A$24", "$A$37"
Zeile = 9
Case "$A$10", "$A$25", "$A$38"
Zeile = 10
Case "$A$11", "$A$26", "$A$39"
Zeile = 11
Case "$A$12", "$A$27", "$A$40"
Zeile = 12
Case "$A$13", "$A$28", "$A$41"
Zeile = 13
Case "$A$14", "$A$29", "$A$42"
Zeile = 14
Case Else
GoTo zumEnde
End Select
dat = 5 ' Datumszeile
Beginn = 0 ' Startwert Null
Ende = 0 ' Startwert Null
Anzahl = 0 ' Startwert Null
Grund = "" ' Startwert Null
txt = "" ' Startwert Null
UserForm1.ListBox1.Clear
' Tage ermitteln
For y = 1 To 2 ' Halbjahr Schleife Januar-Juni und Juli-Dezember
For x = 2 To 185 ' Datumsbereich Schleife
If Cells(Zeile, x) = Sheets("Urlaub").[K2] And Cells(Zeile, x - 1) <> Sheets("Urlaub").[K2] Then Beginn = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K3] And Cells(Zeile, x - 1) <> Sheets("Urlaub").[K3] Then Beginn = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K4] And Cells(Zeile, x - 1) <> Sheets("Urlaub").[K4] Then Beginn = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K5] And Cells(Zeile, x - 1) <> Sheets("Urlaub").[K5] Then Beginn = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K6] And Cells(Zeile, x - 1) <> Sheets("Urlaub").[K6] Then Beginn = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K7] And Cells(Zeile, x - 1) <> Sheets("Urlaub").[K7] Then Beginn = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K8] And Cells(Zeile, x - 1) <> Sheets("Urlaub").[K8] Then Beginn = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K9] And Cells(Zeile, x - 1) <> Sheets("Urlaub").[K9] Then Beginn = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K10] And Cells(Zeile, x - 1) <> Sheets("Urlaub").[K10] Then Beginn = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K11] And Cells(Zeile, x - 1) <> Sheets("Urlaub").[K11] Then Beginn = Cells(dat, x)
' Zeitraumende ermitteln
If Cells(Zeile, x) = Sheets("Urlaub").[K2] And Cells(Zeile, x + 1) <> Sheets("Urlaub").[K2] Then Ende = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K3] And Cells(Zeile, x + 1) <> Sheets("Urlaub").[K3] Then Ende = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K4] And Cells(Zeile, x + 1) <> Sheets("Urlaub").[K4] Then Ende = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K5] And Cells(Zeile, x + 1) <> Sheets("Urlaub").[K5] Then Ende = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K6] And Cells(Zeile, x + 1) <> Sheets("Urlaub").[K6] Then Ende = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K7] And Cells(Zeile, x + 1) <> Sheets("Urlaub").[K7] Then Ende = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K8] And Cells(Zeile, x + 1) <> Sheets("Urlaub").[K8] Then Ende = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K9] And Cells(Zeile, x + 1) <> Sheets("Urlaub").[K9] Then Ende = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K10] And Cells(Zeile, x + 1) <> Sheets("Urlaub").[K10] Then Ende = Cells(dat, x)
If Cells(Zeile, x) = Sheets("Urlaub").[K11] And Cells(Zeile, x + 1) <> Sheets("Urlaub").[K11] Then Ende = Cells(dat, x)
' wenn Anfang und Ende ermittelt Text fortschreiben
If Beginn <> 0 And Ende <> 0 Then
If Cells(Zeile, x) = Sheets("Urlaub").[K2] Then Grund = Sheets("Urlaub").[L2]
If Cells(Zeile, x) = Sheets("Urlaub").[K3] Then Grund = Sheets("Urlaub").[L3]
If Cells(Zeile, x) = Sheets("Urlaub").[K4] Then Grund = Sheets("Urlaub").[L4]
If Cells(Zeile, x) = Sheets("Urlaub").[K5] Then Grund = Sheets("Urlaub").[L5]
If Cells(Zeile, x) = Sheets("Urlaub").[K6] Then Grund = Sheets("Urlaub").[L6]
If Cells(Zeile, x) = Sheets("Urlaub").[K7] Then Grund = Sheets("Urlaub").[L7]
If Cells(Zeile, x) = Sheets("Urlaub").[K8] Then Grund = Sheets("Urlaub").[L8]
If Cells(Zeile, x) = Sheets("Urlaub").[K9] Then Grund = Sheets("Urlaub").[L9]
If Cells(Zeile, x) = Sheets("Urlaub").[K10] Then Grund = Sheets("Urlaub").[L10]
If Cells(Zeile, x) = Sheets("Urlaub").[K11] Then Grund = Sheets("Urlaub").[L11]
Anzahl = DateDiff("d", Beginn, Ende) + 1
' mitzählen in der Auflistung ja/nein
If Grund = Sheets("Urlaub").[L2] And Sheets("Urlaub").[M2] = "Nein" Then GoTo weiter
If Grund = Sheets("Urlaub").[L3] And Sheets("Urlaub").[M3] = "Nein" Then GoTo weiter
If Grund = Sheets("Urlaub").[L4] And Sheets("Urlaub").[M4] = "Nein" Then GoTo weiter
If Grund = Sheets("Urlaub").[L5] And Sheets("Urlaub").[M5] = "Nein" Then GoTo weiter
If Grund = Sheets("Urlaub").[L6] And Sheets("Urlaub").[M6] = "Nein" Then GoTo weiter
If Grund = Sheets("Urlaub").[L7] And Sheets("Urlaub").[M7] = "Nein" Then GoTo weiter
If Grund = Sheets("Urlaub").[L8] And Sheets("Urlaub").[M8] = "Nein" Then GoTo weiter
If Grund = Sheets("Urlaub").[L9] And Sheets("Urlaub").[M9] = "Nein" Then GoTo weiter
If Grund = Sheets("Urlaub").[L10] And Sheets("Urlaub").[M10] = "Nein" Then GoTo weiter
If Grund = Sheets("Urlaub").[L11] And Sheets("Urlaub").[M11] = "Nein" Then GoTo weiter
gAnzahl = gAnzahl + Anzahl
weiter:
' nur 1 Tag, dann Startdatum
If Anzahl = 1 Then txt = " " & Beginn & " = " & Anzahl & " " & Grund
' mehr als 1 Tag, dann Start und Enddatum
If Anzahl > 1 Then txt = " " & Beginn & " bis " & Ende & " = " & Anzahl & " " & Grund
Beginn = 0 ' zurückstellen
Ende = 0 ' zurückstellen
Anzahl = 0 ' zurückstellen
Grund = "" ' zurückstellen
' in ListBox eintragen
UserForm1.ListBox1.AddItem txt
UserForm1.ListBox1.ListIndex = 0
End If
' nächsten Tag finden (Datumsbereich Schleife)
Next x
' nächstes Halbjahr durchsuchen (Halbjahr Schleife)
Zeile = Zeile + 15
dat = dat + 15
Next y
' Userform anzeigen mit Mitarbeiternamen in Fensterüberschrift
UserForm1.Caption = Cells(Target.Row, 1) & " hat " & gAnzahl & " Tage genommen/verplant."
UserForm1.Show
zumEnde:
[a1].Select
End Sub
Jetzt der denn ich einfügen möchte dann ohne option explicit:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' HINTERGRUND
' für Schrift RaZelle.Font.ColorIndex
Dim RaBereich As Range, RaZelle As Range
' Bereich der Wirksamkeit
Set RaBereich = Range("B8:FZ21, B28:FZ41, B48:FZ59, B66:FZ74")
' 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)
If Not Intersect(RaZelle, RaBereich) Is Nothing Then
With RaZelle
Select Case UCase(.Value) ' UMWANDLUNG DER Eingabe in Großbuchstaben
Case "U"
.Interior.ColorIndex = 1
' schwarz
.Font.ColorIndex = 2
' Schriftfarbe weiß
'.NumberFormat = "General"
' Zellenformat Standard
Case "FR"
.Interior.ColorIndex = 6
' weiß
.Font.ColorIndex = 0
' Schriftfarbe automatisch
'.NumberFormat = "General"
' Zellenformat Standard
Case "K"
.Interior.ColorIndex = 3
' rot
.Font.ColorIndex = 2
' Schriftfarbe Weiß
'.NumberFormat = ";;;"
' nicht sichtbar
Case "BT"
.Interior.ColorIndex = 4
' grün
.Font.ColorIndex = 0
' Schriftfarbe automatisch
'.NumberFormat = "General"
' Zellenformat Standard
Case "WS"
.Interior.ColorIndex = 5
' blau
.Font.ColorIndex = 15
' Schriftfarbe automatisch
'.NumberFormat = "General"
' Zellenformat Standard
Case Else
.Interior.ColorIndex = xlNone
' Keine
.Font.ColorIndex = 0
' Schriftfarbe automatisch
'.NumberFormat = "General"
' Zellenformat Standard
End Select
End With
End If
Next RaZelle
' ActiveSheet.protect ("Passwort")
Set RaBereich = Nothing
End Sub