CODE:
Dim Anfang_oben
Dim Anfang_rechts
Dim Ende_oben
Dim Ende_rechts
Dim Text_oben
Dim Text_rechts
Dim Text_Textfeld
Dim Text_Länge
Public Const Erste_Zeile = 9
Public Const Erste_Spalte = 3
Sub Auto_Open()
Sheets("Eingabe").Select
Range("C" & Erste_Zeile).Select
Set neuesMenü = MenuBars(xlWorksheet).Menus.Add(Caption:="Urlaub", Before:="?")
MenuBars(xlWorksheet).Menus("Urlaub").MenuItems.Add Caption:="Termine löschen", OnAction:="Termine_löschen"
MenuBars(xlWorksheet).Menus("Urlaub").MenuItems.Add Caption:="Urlaubliste erstellen", OnAction:="Urlaubsliste_erstellen", Before:="Termine löschen"
End Sub
Private Sub Textfeld_erstellen()
With Worksheets("Urlaubsliste")
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, Text_rechts, Text_oben, Text_Länge, 8).Select
Textfeld = Selection.Name
.TextBoxes(Textfeld).Characters.Text = Text_Textfeld
.TextBoxes(Textfeld).ShapeRange.Line.Visible = msoFalse
.TextBoxes(Textfeld).Font.Name = "Arial Narrow"
.TextBoxes(Textfeld).Font.FontStyle = "Standard"
.TextBoxes(Textfeld).Font.Size = 5
.TextBoxes(Textfeld).HorizontalAlignment = xlCenter
End With
End Sub
Private Sub Linie_zeichnen()
With Worksheets("Urlaubsliste")
.Shapes.AddLine(Anfang_rechts, Anfang_oben, Ende_rechts, Ende_oben).Select
Linienname = Selection.Name
.Shapes(Linienname).Line.Weight = 0.75
.Shapes(Linienname).Line.BeginArrowheadLength = msoArrowheadShort
.Shapes(Linienname).Line.BeginArrowheadWidth = msoArrowheadNarrow
.Shapes(Linienname).Line.BeginArrowheadStyle = msoArrowheadTriangle
.Shapes(Linienname).Line.EndArrowheadLength = msoArrowheadShort
.Shapes(Linienname).Line.EndArrowheadWidth = msoArrowheadNarrow
.Shapes(Linienname).Line.EndArrowheadStyle = msoArrowheadTriangle
.Shapes(Linienname).Line.ForeColor.SchemeColor = 8
End With
End Sub
Sub Urlaubsliste_erstellen()
If Sheets("Eingabe").Range("B1") = "" Then
MsgBox "Eingabe Jahr fehlt"
Sheets("Eingabe").Select
Range("B1").Select
Exit Sub
End If
If IsNumeric(Sheets("Eingabe").Range("B1")) = False Then
MsgBox "Eingabe Jahr ist keine Zahl"
Sheets("Eingabe").Select
Range("B1").Select
Exit Sub
End If
Application.ScreenUpdating = False
Sheets("Eingabe").Select
Dim x As Range
For Each x In Sheets("Eingabe").Range(Cells(Erste_Zeile, Erste_Spalte), Cells(Erste_Zeile + 24, Erste_Spalte + 40 - 1))
If x.Value <> "" Then
If IsDate(x) = True Then
If Year(x) < Sheets("Eingabe").Range("B1") Then
x.Select
MsgBox "falsches Jahr"
Exit Sub
End If
Else
x.Select
MsgBox "falsches Datum"
Exit Sub
End If
End If
Next
With Sheets("Eingabe")
Anzahl_Tage = Format(CDate("31.12." & .Range("B1")), 0) - Format(CDate("01.01." & .Range("B1")), 0) + 1
End With
If Anzahl_Tage = 365 Then
ReDim Punkte(1 To 365)
For i = 1 To 365
Punkte(i) = 1.65
Next
Punkte(31) = 1.523
Punkte(57) = 1.66
Punkte(58) = 1.66
Punkte(59) = 1.66
Punkte(90) = 1.523
Punkte(151) = 1.523
Punkte(212) = 1.523
Punkte(243) = 1.523
Punkte(304) = 1.523
Punkte(365) = 1.523
Else
ReDim Punkte(1 To 366)
For i = 1 To 366
Punkte(i) = 1.65
Next
Punkte(31) = 1.523
Punkte(57) = 1.245
Punkte(58) = 1.245
Punkte(59) = 1.245
Punkte(60) = 1.245
Punkte(91) = 1.523
Punkte(152) = 1.523
Punkte(213) = 1.523
Punkte(244) = 1.523
Punkte(305) = 1.523
Punkte(366) = 1.523
End If
Worksheets("Urlaubsliste").Select
Application.ScreenUpdating = True
Call Linien_löschen
Worksheets("Urlaubsliste").Range("A1") = "Urlaubssübersicht "
Worksheets("Urlaubsliste").Range("A2") = "Schicht " & Sheets("Eingabe").Range("B3")
Worksheets("Urlaubsliste").Range("CB1") = Format(Sheets("Eingabe").Range("B1"), "0")
If Sheets("Eingabe").Range("B4") <> "" Then Worksheets("Urlaubsliste").Range("P2") = "Sachbearbeiter: " & Sheets("Eingabe").Range("B4")
For z = 1 To 25
Worksheets("Urlaubsliste").Range("A" & z + 5) = Sheets("Eingabe").Range("A" & z + Erste_Zeile - 1)
Worksheets("Urlaubsliste").Range("B" & z + 5) = Sheets("Eingabe").Range("B" & z + Erste_Zeile - 1)
Next
With Sheets("Eingabe")
Anfang_Jahr = Format(CDate("01.01." & .Range("B1")), 0)
For z = 1 To 25
For s = 1 To 40 Step 2
If .Cells(z + Erste_Zeile - 1, s + Erste_Spalte - 1) <> "" Or .Cells(z + Erste_Zeile - 1, s + Erste_Spalte) <> "" Then
Erster_Tag = .Cells(z + Erste_Zeile - 1, s + Erste_Spalte - 1)
Letzter_Tag = .Cells(z + Erste_Zeile - 1, s + Erste_Spalte)
If Erster_Tag = 0 Then
MsgBox "zweites Datum fehlt"
Call Linien_löschen
Sheets("Eingabe").Select
.Cells(z + Erste_Zeile - 1, s + Erste_Spalte - 1).Select
Exit Sub
End If
If Letzter_Tag = 0 Then
MsgBox "zweites Datum fehlt"
Call Linien_löschen
Sheets("Eingabe").Select
.Cells(z + Erste_Zeile - 1, s + Erste_Spalte).Select
Exit Sub
End If
If Erster_Tag > Letzter_Tag Then
MsgBox "Erster Tag > Letzter Tag"
Call Linien_löschen
Sheets("Eingabe").Select
.Cells(z + Erste_Zeile - 1, s + Erste_Spalte - 1).Select
Exit Sub
End If
If Letzter_Tag - Erster_Tag > 200 Then
MsgBox "zweiter Termin ist falsch, max 200 Tage"
Call Linien_löschen
Sheets("Eingabe").Select
.Cells(z + Erste_Zeile - 1, s + Erste_Spalte).Select
Exit Sub
End If
x1 = Format(Erster_Tag, 0) - Anfang_Jahr
x2 = Format(Letzter_Tag, 0) - Anfang_Jahr + 1
If x2 - x1 = 1 Then
x1 = x1 - 1
x2 = x2 + 1
End If
If x1 <= 0 Then x1 = 0
If x1 > Anzahl_Tage - 4 Then x1 = Anzahl_Tage - 4
If x2 > Anzahl_Tage Then x2 = Anzahl_Tage
If x2 < 4 Then x2 = 4
For i1 = 1 To x1
i2 = i2 + Punkte(i1)
Next
Anfang_rechts = i2 + 95
If Anfang_rechts < 95 Then Anfang_rechts = 95
i2 = 0
For i3 = 1 To x2
i4 = i4 + Punkte(i3)
Next
Ende_rechts = i4 + 95
If Ende_rechts > 696 Then Ende_rechts = 696
i4 = 0
Anfang_oben = z * 14.25 + 86
Ende_oben = z * 14.25 + 86
Call Linie_zeichnen
If Erster_Tag = Letzter_Tag Then
Text_Textfeld = Format(Erster_Tag, "dd.mm")
Text_Länge = 18
Text_rechts = (Ende_rechts + Anfang_rechts) / 2 - 9
If Text_rechts < 96 Then Text_rechts = 96
If Text_rechts > 696 - 19 Then Text_rechts = 696 - 19
Else
Text_Textfeld = Format(Erster_Tag, "dd.mm") & "-" & Format(Letzter_Tag, "dd.mm")
Text_Länge = 36
Text_rechts = (Ende_rechts + Anfang_rechts) / 2 - 18
If Text_rechts < 95 Then Text_rechts = 95
If Text_rechts > 696 - 37 Then Text_rechts = 696 - 37
End If
Text_oben = z * 14.25 + 76
Call Textfeld_erstellen
End If
Next
Next
End With
Range("A4").Select
End Sub
Private Sub Linien_löschen()
For Each d In Worksheets("Urlaubsliste").DrawingObjects
d.Delete
Next
Worksheets("Urlaubsliste").Range("A1:CB2").ClearContents
End Sub
Sub Termine_löschen()
Sheets("Eingabe").Select
Frage = MsgBox("Sollen die Termine wirklich gelöscht werden?", 16 + vbYesNo + vbDefaultButton2)
If Frage = vbNo Then
Exit Sub
End If
Range(Cells(Erste_Zeile, Erste_Spalte - 1), Cells(Erste_Zeile + 24, Erste_Spalte + 40 - 1)).ClearContents
Sheets("Eingabe").Range("B1").ClearContents
End Sub