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
  ''If Application.WorksheetFunction.Weekday(DateSerial(Jahr, Monat, 1), 1) = 1 Then Datum = Datum + 7
  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)                           'begin of month not 1.
Dim a, Anz_Eigenschaften, d, day, i, l, Page, s, z, bmnf, dpm As Integer
Dim Datum As Double                                      'days per month
Dim erster_Montag, funktion, name, strPfad, RootPath As String
Dim First, found, smart As Boolean         '   "    + Neue Tagebücher\
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
      '''''''''''''
      ''Feiertage''
      '''''''''''''
      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                                               ''+4 cause Jan. Week supposed to start with 1.
    Sheets(i).Range("E7:F7").FormulaR1C1 = "=WEEKNUM(R[7]C[-1]+4)&"". KW ""&Übersicht!R[-4]C[-2]"
                                         ''"=Übersicht!R[" & Range(Montag).Row - 6 & "]C[" & Range(Montag).Column - 4 & "]+((R[50]C)-1) &"". KW ""&Übersicht!R[-4]C[-1]"
  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 'from i = 40 to this line probably unnecessary
  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                                        'check next month if bmnf works properly
      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
    ''''''''''''''''''''''''''''''''' |
    ''check if autosort is possible'' |
    ''''''''''''''''''''''''''''''''' V
    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