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