Public
Function
erster_Montag(Monat
As
Integer
, Jahr
As
Integer
)
As
Currency
Dim
Datum
As
Long
Datum = DateSerial(Jahr, Monat, 1)
If
Application.WorksheetFunction.Weekday(Datum, 2) = 1
Then
erster_Montag = Datum
Exit
Function
End
If
If
Application.WorksheetFunction.Weekday(Datum, 2) = 7
Then
erster_Montag = DateSerial(Jahr, Monat, 2)
Exit
Function
End
If
If
Application.WorksheetFunction.Weekday(Datum, 2) = 6
Then
erster_Montag = DateSerial(Jahr, Monat, 3)
Exit
Function
End
If
i = -1
Do
i = i + 1
Datum = DateSerial(Jahr, Monat - 1, 31 - i)
Loop
Until
Application.WorksheetFunction.Weekday(Datum, 2) = 1
erster_Montag = Datum
End
Function
Sub
SchutzAufheben()
Dim
Page, Seite, Var
As
Integer
Seite = ActiveSheet.Index
Page = ActiveWorkbook.Worksheets.Count
Var = 0
Do
Var = Var + 1
Sheets(Var).Unprotect
Loop
Until
Var = Page
Sheets(Seite).
Select
End
Sub
Sub
SchutzSetzen()
Dim
Page, Seite, Var
As
Integer
Seite = ActiveSheet.Index
Page = ActiveWorkbook.Worksheets.Count
Var = 0
Do
Var = Var + 1
Sheets(Var).Protect DrawingObjects:=
True
, Contents:=
True
, Scenarios:=
True
Loop
Until
Var = 2
Do
Var = Var + 1
Sheets(Var).Protect DrawingObjects:=
True
, Contents:=
True
, Scenarios:=
True
_
, AllowFormattingCells:=
True
, AllowFormattingColumns:=
True
, _
AllowFormattingRows:=
True
, AllowInsertingColumns:=
True
, AllowInsertingRows _
:=
True
, AllowDeletingColumns:=
True
, AllowDeletingRows:=
True
Loop
Until
Var = Page
Sheets(Seite).
Select
End
Sub
Sub
Tagebücher_erstellen()
Dim
Mitarbeiter(200, 10)
Dim
a, Anz_Eigenschaften, d, day, i, l, Page, s, z, bmnf, dpm
As
Integer
Dim
Datum
As
Double
Dim
erster_Montag, funktion, name, strPfad, RootPath
As
String
Dim
First, found, smart
As
Boolean
Dim
Montag
As
Variant
Dim
objFSO
As
Object
Dim
objFolder
As
Object
Dim
objSubfolder
As
Object
, colSubfolders
As
Object
Dim
tribool, Adresse, Cache
As
Integer
Dim
Mitarbeiteradresse(200, 1)
Dim
Overlap
As
Integer
If
MsgBox(
"Tagebücher in den entsprechenden Mitarbeiterordner speichern ?"
, vbYesNo) = vbNo
Then
smart =
False
Else
If
MsgBox(
"Sind Sie sicher, dass Sie die Tagebücher in die Mitarbeiterordner speichern wollen ?"
, vbYesNo) = vbYes
Then
smart =
True
Else
smart =
False
End
If
RootPath = ThisWorkbook.Path + "\Neue Tagebücher\"
Call
SchutzAufheben
Sheets(3).Range(
"B3"
).FormulaR1C1 =
"=Übersicht!RC"
Sheets(3).Range(
"C3"
).FormulaR1C1 =
"=Übersicht!RC"
i = 3
Do
i = i + 1
If
i > 100
Then
MsgBox (
"Funktion 'erster_Montag' nicht vorhanden."
)
Exit
Sub
End
If
Loop
Until
Sheets(2).Cells(i, 5).Formula
Like
"*erster_Montag*"
Montag = Sheets(2).Cells(i, 5).Address
d = 0
i = 13
Do
d = d + 1
i = i + 1
Datum = DateSerial(Sheets(3).Cells(3, 3).Value, Sheets(3).Cells(3, 2).Value, d)
Sheets(3).Cells(i, 2).Value = Datum
Sheets(3).Cells(i, 2).NumberFormat =
"dd/mm/yy"
If
i > 40
Then
With
Sheets(3).Cells(i, 2).Interior
.Pattern = xlSolid
.TintAndShade = -0.149998474074526
End
With
End
If
Loop
Until
Month(Datum + 1) <> Sheets(3).Cells(3, 2).Value
If
i < 44
Then
Do
i = i + 1
Sheets(3).Cells(i, 2).Value =
""
With
Sheets(3).Cells(i, 2).Interior
.Pattern = xlNone
.TintAndShade = 0
End
With
Loop
Until
i >= 44
End
If
Sheets(3).Range(
"C14:AE44"
).Interior.Pattern = xlNone
i = 13
Do
i = i + 1
Sheets(3).Cells(i, 26).Value =
"=E3"
Loop
Until
i = 44
i = 13
Do
i = i + 1
If
Sheets(3).Cells(i, 2).Value = 0
Then
Sheets(3).Cells(i, 3).Value =
""
Else
:
Select
Case
Application.WorksheetFunction.Weekday(Sheets(3).Cells(i, 2).Value, 1)
Case
1
Sheets(3).Cells(i, 3).Value =
"Sonntag"
With
Sheets(3).Range(Sheets(3).Cells(i, 3), Sheets(3).Cells(i, 31)).Interior
.Pattern = xlSolid
.TintAndShade = -0.149998474074526
End
With
Sheets(3).Cells(i, 26).Value =
""
Case
2
Sheets(3).Cells(i, 3).Value =
"Mo"
Case
3
Sheets(3).Cells(i, 3).Value =
"Di"
Case
4
Sheets(3).Cells(i, 3).Value =
"Mi"
Case
5
Sheets(3).Cells(i, 3).Value =
"Do"
Case
6
Sheets(3).Cells(i, 3).Value =
"Fr"
Case
7
Sheets(3).Cells(i, 3).Value =
"Samstag"
Sheets(3).Cells(i, 26).Value =
""
End
Select
If
((Format(Sheets(3).Cells(i, 2).Value,
"DD"
) = 1
And
Format(Sheets(3).Cells(i, 2).Value,
"MM"
) = 1) _
Or
(Format(Sheets(3).Cells(i, 2).Value,
"DD"
) = 18
And
Format(Sheets(3).Cells(i, 2).Value,
"MM"
) = 4) _
Or
(Format(Sheets(3).Cells(i, 2).Value,
"DD"
) = 21
And
Format(Sheets(3).Cells(i, 2).Value,
"MM"
) = 4) _
Or
(Format(Sheets(3).Cells(i, 2).Value,
"DD"
) = 1
And
Format(Sheets(3).Cells(i, 2).Value,
"MM"
) = 5) _
Or
(Format(Sheets(3).Cells(i, 2).Value,
"DD"
) = 29
And
Format(Sheets(3).Cells(i, 2).Value,
"MM"
) = 5) _
Or
(Format(Sheets(3).Cells(i, 2).Value,
"DD"
) = 9
And
Format(Sheets(3).Cells(i, 2).Value,
"MM"
) = 6) _
Or
(Format(Sheets(3).Cells(i, 2).Value,
"DD"
) = 3
And
Format(Sheets(3).Cells(i, 2).Value,
"MM"
) = 10) _
Or
(Format(Sheets(3).Cells(i, 2).Value,
"DD"
) = 25
And
Format(Sheets(3).Cells(i, 2).Value,
"MM"
) = 12) _
Or
(Format(Sheets(3).Cells(i, 2).Value,
"DD"
) = 26
And
Format(Sheets(3).Cells(i, 2).Value,
"MM"
) = 12))
Then
With
Sheets(3).Range(Sheets(3).Cells(i, 3), Sheets(3).Cells(i, 31)).Interior
.Pattern = xlSolid
.TintAndShade = -0.149998474074526
End
With
Sheets(3).Cells(i, 26).Value =
""
End
If
End
If
Loop
Until
Month(Sheets(3).Cells(i, 2).Value + 1) <> Sheets(3).Cells(3, 2).Value
Sheets(3).Range(
"Y39"
).AutoFill Destination:=Sheets(3).Range(
"Y39:Y44"
), Type:=xlFillValues
Sheets(3).Range(
"AB39"
).AutoFill Destination:=Sheets(3).Range(
"AB39:AB44"
), Type:=xlFillValues
Sheets(3).Range(
"AC39"
).AutoFill Destination:=Sheets(3).Range(
"AC39:AC44"
), Type:=xlFillValues
day = i
dpm = i
Sheets(3).Cells(45, 29).Value =
"=AC"
& i
If
i < 44
Then
Do
i = i + 1
Sheets(3).Cells(i, 26).ClearContents
Sheets(3).Cells(i, 29).ClearContents
Loop
Until
i = 44
End
If
i = day
If
i < 44
Then
Do
i = i + 1
Sheets(3).Cells(i, 3).Value =
""
Loop
Until
i = 44
End
If
i = 13
Do
i = i + 1
If
Sheets(3).Cells(i, 2).Value >= Sheets(2).Range(Montag).Value
Then
day = i
Exit
Do
End
If
Loop
Page = ActiveWorkbook.Worksheets.Count
If
Page < 8
Then
Do
Application.DisplayAlerts =
False
Sheets(Page).Copy After:=Sheets(Page)
Application.DisplayAlerts =
True
Page = Page + 1
Loop
Until
Page = 8
End
If
i = 3
Page = ActiveWorkbook.Worksheets.Count
Do
i = i + 1
Sheets(i).Range(
"E7:F7"
).FormulaR1C1 =
"=WEEKNUM(R[7]C[-1]+4)&"
". KW "
"&Übersicht!R[-4]C[-2]"
Loop
Until
i = Page
i = 3
Do
i = i + 1
Sheets(i).Range(
"E68"
).Value = i - 3
Loop
Until
i = Page
i = 3
Do
i = i + 1
Sheets(i).name = i
Loop
Until
i = Page
Sheets(3).Range(
"D14:I44"
).ClearContents
i = 40
Do
i = i + 1
If
Sheets(3).Cells(i, 2).Value = 0
Then
Sheets(3).Range(Sheets(3).Cells(i, 3), Sheets(3).Cells(i, 7)).Value =
""
Loop
Until
i > 43
With
Sheets(3).Range(
"K:K"
).Interior
.Pattern = xlNone
.TintAndShade = 0
End
With
With
Sheets(3).Range(
"Y:Y"
).Interior
.Pattern = xlNone
.TintAndShade = 0
End
With
With
Sheets(3).Range(
"AD:AD"
).Interior
.Pattern = xlNone
.TintAndShade = 0
End
With
Page = ActiveWorkbook.Worksheets.Count
For
i = 4
To
Page
Sheets(i).Range(
"E14:G20"
).ClearContents
If
Mid$(Sheets(i).Cells(7, 5).Value, 2, 1) =
"."
Then
Sheets(i).name =
"KW "
& Left(Sheets(i).Cells(7, 5).Value, 1)
Else
:
Sheets(i).name =
"KW "
& Left(Sheets(i).Cells(7, 5).Value, 2)
End
If
Next
i
If
Month(Sheets(4).Cells(14, 4).Value) < Sheets(2).Cells(3, 2).Value
Then
Sheets(4).Cells(7, 5).Copy
Sheets(4).Cells(7, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=
False
, Transpose:=
False
Application.CutCopyMode =
False
If
Mid$(Sheets(4).Cells(7, 5).Value, 2, 1) =
"."
Then
Sheets(4).Cells(7, 5).Value = Left(Sheets(4).Cells(7, 5).Value, 2) & 2 & Right(Sheets(4).Cells(7, 5).Value, Len(Sheets(4).Cells(7, 5).Value) - 2)
Sheets(4).name =
"KW "
& Left(Sheets(4).Cells(7, 5).Value, 3)
Else
:
Sheets(4).Cells(7, 5).Value = Left(Sheets(4).Cells(7, 5).Value, 3) & 2 & Right(Sheets(4).Cells(7, 5).Value, Len(Sheets(4).Cells(7, 5).Value) - 3)
Sheets(4).name =
"KW "
& Left(Sheets(4).Cells(7, 5).Value, 4)
End
If
End
If
If
Month(Sheets(Page).Cells(19, 4).Value) > Sheets(2).Cells(3, 2).Value
Then
Sheets(Page).Cells(7, 5).Copy
Sheets(Page).Cells(7, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=
False
, Transpose:=
False
Application.CutCopyMode =
False
If
Mid$(Sheets(Page).Cells(7, 5).Value, 2, 1) =
"."
Then
Sheets(Page).Cells(7, 5).Value = Left(Sheets(Page).Cells(7, 5).Value, 2) & 1 & Right(Sheets(Page).Cells(7, 5).Value, Len(Sheets(Page).Cells(7, 5).Value) - 2)
Sheets(Page).name =
"KW "
& Left(Sheets(Page).Cells(7, 5).Value, 3)
Else
:
Sheets(Page).Cells(7, 5).Value = Left(Sheets(Page).Cells(7, 5).Value, 3) & 1 & Right(Sheets(Page).Cells(7, 5).Value, Len(Sheets(Page).Cells(7, 5).Value) - 3)
Sheets(Page).name =
"KW "
& Left(Sheets(Page).Cells(7, 5).Value, 4)
End
If
End
If
bmnf = 0
Overlap = -1
Do
Overlap = Overlap + 1
If
Overlap > 6
Then
bmnf = bmnf + 1
Overlap = 0
End
If
Loop
Until
((1 * Format(Sheets(4).Cells(14 + Overlap, 4).Value,
"DD"
)) < (2 + bmnf))
For
Page = 4
To
ActiveWorkbook.Worksheets.Count
For
i = 14
To
20
If
(((Page = 4)
And
((1 * Format(Sheets(4).Cells(i, 4).Value,
"DD"
)) < 8 + bmnf))
Or
((Page > 4)
And
(i + 7 * (Page - 4) - Overlap <= dpm)))
Then
Sheets(Page).Cells(i, 5).FormulaR1C1 = _
"=IF(Projektkarte!R["
& 7 * (Page - 4) - Overlap + bmnf &
"]C[-1]=0,"
""
",Projektkarte!R["
& 7 * (Page - 4) - Overlap + bmnf &
"]C[-1])"
Sheets(Page).Cells(i, 6).FormulaR1C1 = _
"=IF(Projektkarte!R["
& 7 * (Page - 4) - Overlap + bmnf &
"]C[1]=0,"
""
",Projektkarte!R["
& 7 * (Page - 4) - Overlap + bmnf &
"]C[1])"
Sheets(Page).Cells(i, 7).FormulaR1C1 = _
"=IF(OR(Projektkarte!R["
& 7 * (Page - 4) - Overlap + bmnf &
"]C[-2]=0,Projektkarte!R["
& 7 * (Page - 4) - Overlap + bmnf &
"]C[-1]=0),"
""
",Projektkarte!R["
& 7 * (Page - 4) - Overlap + bmnf &
"]C[-1]-Projektkarte!R["
& 7 * (Page - 4) - Overlap + bmnf &
"]C[-2])"
End
If
Next
i
Next
Page
If
Month(Sheets(ActiveWorkbook.Worksheets.Count).Cells(14, 4).Value) > Sheets(2).Cells(3, 2).Value
Then
Application.DisplayAlerts =
False
Sheets(ActiveWorkbook.Worksheets.Count).Delete
Application.DisplayAlerts =
True
End
If
ActiveWorkbook.Save
Call
SchutzAufheben
i = 3
Do
i = i + 1
If
i > 100
Then
MsgBox (
"Funktion 'erster_Montag' nicht vorhanden."
)
Exit
Sub
End
If
Loop
Until
Sheets(2).Cells(i, 5).Formula
Like
"*erster_Montag*"
Montag = Sheets(2).Cells(i, 5).Address
i = 3
Do
i = i + 1
If
i > 100
Then
MsgBox (
"Funktion '=KALENDERWOCHE()' nicht vorhanden."
)
Exit
Sub
End
If
Loop
Until
Sheets(2).Cells(i, 5).Formula
Like
"*WEEKNUM*"
Sheets(2).Cells(i, 5).Copy
Sheets(2).Cells(i, 5).PasteSpecial Paste:=xlPasteValues
Page = ActiveWorkbook.Worksheets.Count
i = 3
Do
i = i + 1
Sheets(i).name = Left(Sheets(i).Cells(7, 5).Value, Len(Sheets(i).Cells(7, 5).Value) - 5)
Loop
Until
i = Page
Sheets(2).Outline.ShowLevels RowLevels:=2
erster_Montag = Sheets(1).Range(Montag).Value
i = 0
s = 0
z = 0
Do
s = s + 1
Mitarbeiter(z, s) = Sheets(1).Cells(z + 3, s + 1).Value
If
z = 3
Then
i = i + 1
Loop
Until
Sheets(1).Cells(z + 3, s + 2).Value = 0
Anz_Eigenschaften = s
z = -1
Do
s = 0
z = z + 1
Do
s = s + 1
Mitarbeiter(z, s) = Sheets(1).Cells(z + 3, s + 1).Value
If
z = 3
Then
i = i + 1
Loop
Until
s = Anz_Eigenschaften
Loop
Until
Sheets(1).Cells(z + 4, 2).Value = 0
Call
SchutzAufheben
Application.DisplayAlerts =
False
Sheets(1).Delete
Application.DisplayAlerts =
True
For
Page = 3
To
ActiveWorkbook.Sheets.Count
Sheets(Page).
Select
Sheets(Page).Range(
"D14:D20"
).
Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=
False
, Transpose:=
False
Application.CutCopyMode =
False
Sheets(Page).Range(
"E7:F7"
).
Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=
False
, Transpose:=
False
Application.CutCopyMode =
False
Next
Page
Sheets(1).
Select
Sheets(1).Range(
"A1"
).
Select
Sheets(1).Rows(
"22:28"
).Delete Shift:=xlUp
z = 0
If
smart
Then
strPfad = Left(ThisWorkbook.Path, Len(ThisWorkbook.Path) - 22) +
"\Flughafen Schönefeld FGT Los 5\Bautagebuch"
Set
objFSO = CreateObject(
"Scripting.FileSystemObject"
)
Set
objFolder = objFSO.GetFolder(strPfad)
Set
colSubfolders = objFolder.Subfolders
Adresse = -1
For
Each
objSubfolder
In
colSubfolders
If
IsError(Application.Match(objSubfolder.name, Columns(1), 0))
Then
Adresse = Adresse + 1
Mitarbeiteradresse(Adresse, 0) = objSubfolder.name
Mitarbeiteradresse(Adresse, 1) = objSubfolder.Path
End
If
Next
objSubfolder
Set
objFolder =
Nothing
Set
colSubfolders =
Nothing
Set
objFSO =
Nothing
End
If
If
Dir(ThisWorkbook.Path &
"\Neue Tagebücher\", vbDirectory) = "
"
Then
MkDir (ThisWorkbook.Path &
"\Neue Tagebücher"
)
Else
:
ChDir ThisWorkbook.Path &
"\Neue Tagebücher"
End
If
Application.DisplayAlerts =
False
Call
SchutzSetzen
Do
z = z + 1
s = 0
Sheets(1).Unprotect
Do
s = s + 1
Sheets(1).Range(Mitarbeiter(0, s)).Value = Mitarbeiter(z, s)
Loop
Until
s = i
Sheets(1).Protect DrawingObjects:=
True
, Contents:=
True
, Scenarios:=
True
If
smart
Then
tribool = 0
Adresse = -1
Do
Adresse = Adresse + 1
If
"*"
+ Mitarbeiter(z, 1) +
"*"
Like
"*"
+ Mitarbeiteradresse(Adresse, 0) +
"*"
Then
If
tribool = 1
Then
tribool = 2
If
tribool = 0
Then
tribool = 1
Cache = Adresse
End
If
End
If
Loop
Until
Adresse = 200
Or
Mitarbeiteradresse(Adresse + 1, 0) =
""
If
tribool = 1
And
Dir(Mitarbeiteradresse(Cache, 1) &
"\Bautagebuch "
& Format(
"1."
& Sheets(2).Range(
"B3"
).Value &
"."
_
& Sheets(2).Range(
"C3"
).Value,
"MMMM"
) &
" "
& Sheets(2).Range(
"C3"
).Value &
" "
& Mitarbeiter(z, 1) &
".xlsx"
) =
""
Then
ActiveWorkbook.SaveAs Filename:= _
Mitarbeiteradresse(Cache, 1) &
"\Bautagebuch "
& Format(
"1."
& Sheets(2).Range(
"B3"
).Value &
"."
_
& Sheets(2).Range(
"C3"
).Value,
"MMMM"
) &
" "
& Sheets(2).Range(
"C3"
).Value &
" "
& Mitarbeiter(z, 1) &
".xlsx"
, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=
False
End
If
Else
:
ActiveWorkbook.SaveAs Filename:= _
RootPath &
"Bautagebuch "
& Format(
"1."
& Sheets(2).Range(
"B3"
).Value &
"."
_
& Sheets(2).Range(
"C3"
).Value,
"MMMM"
) &
" "
& Sheets(2).Range(
"C3"
).Value &
" "
& Mitarbeiter(z, 1) &
".xlsx"
, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=
False
End
If
Loop
Until
((Mitarbeiter(z + 1, 1) = 0)
Or
(Mitarbeiter(z + 1, 1) =
""
))
Application.DisplayAlerts =
False
Application.Quit
End
Sub