Private Sub Workbook_BeforeClose(Cancel As Boolean) On Error Resume Next ThisWorkbook.Sheets(1).Range("C8:E19").ClearContents ThisWorkbook.Sheets(1).Range("H8:H33").ClearContents ThisWorkbook.Sheets(1).Range("J8:J33").ClearContents ThisWorkbook.Sheets(1).Range("D22:E33").ClearContents ThisWorkbook.Sheets(1).Range("G34:J34").ClearContents Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone Selection.Borders(xlEdgeLeft).LineStyle = xlNone Selection.Borders(xlEdgeTop).LineStyle = xlNone Selection.Borders(xlEdgeBottom).LineStyle = xlNone Selection.Borders(xlEdgeRight).LineStyle = xlNone Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone ThisWorkbook.Sheets(1).Range("G7:J33").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With Application.DisplayAlerts = False ActiveWorkbook.Save End Sub Public Sub Workbook_Open() Dim i As Long, j As Long, k As Long, l As Long, y As Long, z As Long, dreifünf As Double Dim heute As Date, jetzt As String, alibi As Boolean Dim TabName As Variant, lackofdata As Boolean, todayfull As Boolean On Error GoTo ErrHandler ThisWorkbook.Sheets(1).Activate lackofdata = False todayfull = False heute = Date jetzt = Left(Time(), 5) TabName = Worksheets(2).Name k = Year(Date) - TabName + 2 If k > ThisWorkbook.Sheets.Count Then If MsgBox("Es scheint, als ob für das aktuelle Jahr (" & Year(Date) & ") noch kein Tabellenblatt vorhanden ist. Möchtest du eines generieren?", vbYesNo, "Fehlendes Tabellenblatt") = vbYes Then Call newSheet Else MsgBox "Bitte lege selbstständig ein neues Tabellenblatt an!" Exit Sub End If End If If IstFeiertag(heute) = True Then MsgBox "Heute ist ein Feiertag! Geh nach Hause und genieße deinen freien Tag!" ThisWorkbook.Sheets(1).Range("G34:J34").ClearContents ThisWorkbook.Sheets(1).Range("G34:J34").ClearContents Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone Selection.Borders(xlEdgeLeft).LineStyle = xlNone Selection.Borders(xlEdgeTop).LineStyle = xlNone Selection.Borders(xlEdgeBottom).LineStyle = xlNone Selection.Borders(xlEdgeRight).LineStyle = xlNone Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone ThisWorkbook.Sheets(1).Range("G7:J33").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With ThisWorkbook .Sheets("Jahresübersicht").Activate .Sheets(1).Cells(22, 4).Value = 0 .Sheets(1).Cells(26, 4).Value = 0 .Sheets(1).Cells(30, 4).Value = 0 .Sheets(1).Range("C8:E19").ClearContents .Sheets(1).Range("H8:H33").ClearContents .Sheets(1).Range("J8:J33").ClearContents For j = 1 To 12 'Arbeitszeiten nach Monaten y = 0 For i = 2 To .Sheets(k).UsedRange.Rows.Count If .Sheets(k).Cells(i, 5).Value = 0 Then Exit For If Month(.Sheets(k).Cells(i, 1).Value) Like Monat(.Sheets(1).Cells(j + 7, 2).Value) Then .Sheets(1).Cells(j + 7, 3).Value = .Sheets(1).Cells(j + 7, 3).Value + .Sheets(k).Cells(i, 5).Value y = y + 1 If Month(.Sheets(k).Cells(i + 1, 1).Value) Like Monat(.Sheets(1).Cells(j + 8, 2).Value) Then Exit For End If Next i If DateDiff("d", .Sheets(k).Cells(i, 1).Value, Date, vbMonday) >= 0 Then .Sheets(1).Cells(j + 7, 4).Value = .Sheets(1).Cells(j + 7, 3).Value - (8 * y) Next j For i = 8 To 33 'Arbeitszeiten nach Kalenderwochen y = 0 l = 0 For j = 2 To .Sheets(k).UsedRange.Rows.Count If .Sheets(k).Cells(j, 1).Formula = "" Then Exit For If .Sheets(k).Cells(j, 5).Value = 0 Then Exit For If KW_DIN(.Sheets(k).Cells(j, 1).Formula) Like Right(.Sheets(1).Cells(i, 7).Value, 2) Then .Sheets(1).Cells(i, 8).Value = .Sheets(1).Cells(i, 8).Value + .Sheets(k).Cells(j, 5).Value y = y + 1 End If If KW_DIN(.Sheets(k).Cells(j, 1).Formula) Like Right(.Sheets(1).Cells(i, 9).Value, 2) Then .Sheets(1).Cells(i, 10).Value = .Sheets(1).Cells(i, 10).Value + .Sheets(k).Cells(j, 5).Value l = l + 1 End If Next j If DateDiff("d", .Sheets(k).Cells(i, 1).Value, Date, vbMonday) >= 0 Then .Sheets(1).Cells(i, 8).Value = .Sheets(1).Cells(i, 8).Value + (.Sheets(1).Cells(i, 8).Value - (y * 8)) .Sheets(1).Cells(i, 10).Value = .Sheets(1).Cells(i, 10).Value + (.Sheets(1).Cells(i, 10).Value - (l * 8)) End If Next i dreifünf = 0 z = 0 For i = 2 To .Sheets(k).UsedRange.Rows.Count '53. KW abfragen und zählen If .Sheets(k).Cells(i, 1).Value Like "" Then Exit For If .Sheets(k).Cells(j, 5).Value = 0 Then Exit For If KW_DIN(.Sheets(k).Cells(i, 1).Formula) = 53 Then '53. KW abfragen dreifünf = dreifünf + .Sheets(k).Cells(i, 5).Value z = z + 1 End If Next End With If dreifünf > 0 Or z > 0 Then ThisWorkbook.Sheets(1).Cells(34, 7).Value = "KW53" ThisWorkbook.Sheets(1).Cells(34, 9).Value = dreifünf + (dreifünf - (z * 8)) ThisWorkbook.Sheets(1).Range("G34:J34").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With Selection.Borders(xlInsideHorizontal).LineStyle = xlNone ThisWorkbook.Sheets(1).Range("B1:J5").Select End If With UF_Begin .opb_traced.Caption = "Erfasste Zeit: " & jetzt .opb_traced.Value = True .tb_time.Enabled = False .Label1.Caption = "Hallo! Diese Datei erfasst automatisch deine Arbeitszeit. Unten siehst Du die aktuell erfasste Zeit, die als Arbeitsbeginn oder Arbeitsende eingetragen wird. Falls diese nicht stimmt, kannst du sie korrigieren. Zusätzlich kannst du noch einen Jahresbeleg ausdrucken oder über den Button >>Editieren<< neue Jahresblätter anlegen." & vbCrLf & vbCrLf & "Abbrechen der Prozedur durch Klick auf das Kreuz, die Datei wird dann ohne Eintragung eines Wertes geschlossen." For i = 2 To Worksheets(k).UsedRange.Rows.Count If ThisWorkbook.Sheets(k).Cells(i, 6).Value Like "Krank" Then ThisWorkbook.Sheets(1).Cells(26, 4).Value = ThisWorkbook.Sheets(1).Cells(26, 4).Value + 1 If ThisWorkbook.Sheets(k).Cells(i, 6).Value Like "Urlaub" Then ThisWorkbook.Sheets(1).Cells(30, 4).Value = ThisWorkbook.Sheets(1).Cells(30, 4).Value + 1 If ThisWorkbook.Sheets(k).Cells(i, 5).Value > 0 Then ThisWorkbook.Sheets(1).Cells(22, 4).Value = ThisWorkbook.Sheets(1).Cells(22, 4).Value + (ThisWorkbook.Sheets(k).Cells(i, 5) - 8) End If heute = Worksheets(k).Cells(i, 1).Value Select Case DateDiff("d", heute, Date, vbMonday) Case Is > 0 If Worksheets(k).Cells(i, 2).Value Like "" Or Worksheets(k).Cells(i, 3).Value Like "" Or Worksheets(k).Cells(i, 4).Value Like "" Then If Worksheets(k).Cells(i, 6).Value Like "" Then lackofdata = True End If Case Is = 0 If Worksheets(k).Cells(i, 2) <> "" And Worksheets(k).Cells(i, 3) <> "" And Worksheets(k).Cells(i, 4) <> "" And Worksheets(k).Cells(i, 6).Value Like "" Then todayfull = True .Label2.Visible = True .tb_minutes.Visible = True Exit For Else .Label2.Visible = True .tb_minutes.Visible = True Exit For End If Case Is < 0 .Label2.Visible = False .tb_minutes.Visible = False Exit For Case Else .Label2.Visible = False .tb_minutes.Visible = False End Select Next i If lackofdata = True Then If todayfull = True Then If MsgBox("Für den heutigen Tag wurden bereits alle Daten eingetragen, es sind aber noch Arbeitstage ohne Arbeits- oder Pausenzeiten vorhanden. Bitte gehe auf " & Chr(34) & "Daten editieren" & Chr(34) & ", um die fehlenden Daten noch einzutragen oder fülle diese Tage als Urlaub bzw. Krankheit aus.", vbExclamation, "Daten bereits vorhanden") Then alibi = True .opb_traced.Enabled = False .opb_self.Enabled = False .tb_time.Enabled = False .tb_minutes.Enabled = False Else If MsgBox("Es fehlen noch Daten. Bitte gehe auf " & Chr(34) & "Daten editieren" & Chr(34) & ", nachdem du die neuen Arbeitszeiten erfasst hast, um die fehlenden Daten einzutragen.", vbExclamation, "Daten bereits vorhanden") Then alibi = True End If Else If todayfull = True Then If MsgBox("Für den heutigen Tag wurden bereits alle Daten eingetragen! Falls du diese ändern möchtest, klicke " & Chr(34) & "Daten editieren" & Chr(34) & "!", vbExclamation, "Daten bereits vorhanden") Then alibi = True .opb_traced.Enabled = False .opb_self.Enabled = False .tb_time.Enabled = False .tb_minutes.Enabled = False End If End If Select Case ThisWorkbook.Sheets(1).Cells(22, 4).Value Case Is > 0 ThisWorkbook.Sheets(1).Range("D22:E25").Select Selection.Font.ThemeColor = xlThemeColorAccent6 Selection.Font.TintAndShade = -0.499984740745262 Case Is < 0 ThisWorkbook.Sheets(1).Range("D22:E25").Select Selection.Font.Color = -16776961 Selection.Font.TintAndShade = 0 Case Is = 0 ThisWorkbook.Sheets(1).Range("D22:E25").Select Selection.Font.Color = -16711681 Selection.Font.TintAndShade = 0 Case Else 'Komplexe Zahl Junge! End Select .Show End With ThisWorkbook.Sheets(1).Range("B1:J5").Select Application.ScreenUpdating = True Exit Sub ErrHandler: If MsgBox("Fehler " & Err.Number & ": " & Err.Description & vbCrLf & "Bitte kontaktieren Sie mich unter info@octooptokoppler.de!", vbCritical, "Fehler!") = vbOK Then Exit Sub End Sub Sub test() End Sub Private Sub Workbook_SheetActivate(ByVal Sh As Object) End Sub Public Sub cb_edit_Click() On Error GoTo ErrHandler Dim i As Long Unload Me With UF_Make .Frame1.Visible = False .Frame2.Visible = False .opb_edit.Value = False .opb_show.Value = False For i = 2 To ThisWorkbook.Sheets.Count .ComboBox1.AddItem (ThisWorkbook.Sheets(i).Name) Next .Show End With Exit Sub ErrHandler: If MsgBox("Fehler " & Err.Number & ": " & Err.Description & vbCrLf & "Bitte kontaktieren Sie mich unter info@octooptokoppler.de!", vbCritical, "Fehler!") = vbOK Then Exit Sub End Sub Public Sub cb_report_Click() On Error GoTo ErrHandler Dim wahl As Variant, auswahl As Variant, stunden As Double, wstunden As Double Dim strOrdner As String Dim DateiName As String, bla As String Dim Datei As String Dim i As Long, j As Long, k As Long, l As Long, dreifünf As Double, z As Long Unload Me Application.ScreenUpdating = False bla = ThisWorkbook.Sheets(1).Cells(1, 2).Value With UF_Year For i = 2 To ThisWorkbook.Sheets.Count .ComboBox1.AddItem ThisWorkbook.Sheets(i).Name Next .Show End With wahl = ThisWorkbook.Sheets(1).Cells(100, 1).Value auswahl = ThisWorkbook.Sheets(1).Cells(100, 2).Value ThisWorkbook.Sheets(1).Range("G34:J34").ClearContents ThisWorkbook.Sheets(1).Range("G34:J34").ClearContents Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone Selection.Borders(xlEdgeLeft).LineStyle = xlNone Selection.Borders(xlEdgeTop).LineStyle = xlNone Selection.Borders(xlEdgeBottom).LineStyle = xlNone Selection.Borders(xlEdgeRight).LineStyle = xlNone Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone Range("G7:J33").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With Application.DisplayAlerts = False ActiveWorkbook.Save With ThisWorkbook .Sheets(1).Cells(22, 4).Value = 0 .Sheets(1).Cells(26, 4).Value = 0 .Sheets(1).Cells(30, 4).Value = 0 .Sheets(1).Range("C8:E19").ClearContents .Sheets(1).Range("H8:H33").ClearContents .Sheets(1).Range("J8:J33").ClearContents For j = 1 To 12 'Arbeitszeiten nach Monaten k = 0 For i = 2 To .Sheets(auswahl + 2).UsedRange.Rows.Count If .Sheets(auswahl + 2).Cells(i, 5).Value = 0 Then Exit For If Month(.Sheets(auswahl + 2).Cells(i, 1).Value) Like Monat(.Sheets(1).Cells(j + 7, 2).Value) Then .Sheets(1).Cells(j + 7, 3).Value = .Sheets(1).Cells(j + 7, 3).Value + .Sheets(auswahl + 2).Cells(i, 5).Value k = k + 1 If Month(.Sheets(auswahl + 2).Cells(i + 1, 1).Value) Like Monat(.Sheets(1).Cells(j + 8, 2).Value) Then Exit For End If Next i If .Sheets(auswahl + 2).Name Like Year(Date) Then If DateDiff("d", .Sheets(k).Cells(i, 1).Value, Date, vbMonday) >= 0 Then .Sheets(1).Cells(j + 7, 4).Value = .Sheets(1).Cells(j + 7, 3).Value - (8 * k) Else .Sheets(1).Cells(j + 7, 4).Value = .Sheets(1).Cells(j + 7, 3).Value - (8 * k) End If Next j For i = 8 To 33 'Arbeitszeiten nach Kalenderwochen k = 0 l = 0 For j = 2 To .Sheets(auswahl + 2).UsedRange.Rows.Count If .Sheets(auswahl + 2).Cells(j, 1).Formula = "" Then Exit For If .Sheets(auswahl + 2).Cells(j, 5).Value = 0 Then Exit For If .Sheets(auswahl + 2).Cells(j, 6).Value Like "Krank" Then .Sheets(1).Cells(26, 4).Value = .Sheets(1).Cells(26, 4).Value + 1 If .Sheets(auswahl + 2).Cells(j, 6).Value Like "Urlaub" Then .Sheets(1).Cells(30, 4).Value = .Sheets(1).Cells(30, 4).Value + 1 .Sheets(1).Cells(22, 4).Value = .Sheets(1).Cells(22, 4).Value + (.Sheets(auswahl + 2).Cells(j, 5) - 8) If KW_DIN(.Sheets(auswahl + 2).Cells(j, 1).Formula) Like Right(.Sheets(1).Cells(i, 7).Value, 2) Then .Sheets(1).Cells(i, 8).Value = .Sheets(1).Cells(i, 8).Value + .Sheets(auswahl + 2).Cells(j, 5).Value k = k + 1 End If If KW_DIN(.Sheets(auswahl + 2).Cells(j, 1).Formula) Like Right(.Sheets(1).Cells(i, 9).Value, 2) Then .Sheets(1).Cells(i, 10).Value = .Sheets(1).Cells(i, 10).Value + .Sheets(auswahl + 2).Cells(j, 5).Value l = l + 1 End If Next j If .Sheets(auswahl + 2).Name Like Year(Date) Then If DateDiff("d", .Sheets(k).Cells(i, 1).Value, Date, vbMonday) >= 0 Then .Sheets(1).Cells(i, 8).Value = .Sheets(1).Cells(i, 8).Value + (.Sheets(1).Cells(i, 8).Value - (k * 8)) .Sheets(1).Cells(i, 10).Value = .Sheets(1).Cells(i, 10).Value + (.Sheets(1).Cells(i, 10).Value - (l * 8)) End If Else .Sheets(1).Cells(i, 8).Value = .Sheets(1).Cells(i, 8).Value + (.Sheets(1).Cells(i, 8).Value - (k * 8)) .Sheets(1).Cells(i, 10).Value = .Sheets(1).Cells(i, 10).Value + (.Sheets(1).Cells(i, 10).Value - (l * 8)) End If Next i dreifünf = 0 z = 0 For i = 2 To .Sheets(auswahl + 2).UsedRange.Rows.Count '53. KW abfragen und zählen If .Sheets(auswahl + 2).Cells(i, 1).Value Like "" Then Exit For If KW_DIN(.Sheets(auswahl + 2).Cells(i, 1).Formula) = 53 Then '53. KW abfragen dreifünf = dreifünf + .Sheets(auswahl + 2).Cells(i, 5).Value z = z + 1 End If Next End With If dreifünf > 0 Or z > 0 Then ThisWorkbook.Sheets(1).Cells(34, 7).Value = "KW53" ThisWorkbook.Sheets(1).Cells(34, 9).Value = dreifünf + (dreifünf - (z * 8)) ThisWorkbook.Sheets(1).Range("G34:J34").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With Selection.Borders(xlInsideHorizontal).LineStyle = xlNone ThisWorkbook.Sheets(1).Range("B1:J5").Select End If Select Case ThisWorkbook.Sheets(1).Cells(22, 4).Value Case Is > 0 ThisWorkbook.Sheets(1).Range("D22:E25").Select Selection.Font.ThemeColor = xlThemeColorAccent6 Selection.Font.TintAndShade = -0.499984740745262 Case Is < 0 ThisWorkbook.Sheets(1).Range("D22:E25").Select Selection.Font.Color = -16776961 Selection.Font.TintAndShade = 0 Case Is = 0 ThisWorkbook.Sheets(1).Range("D22:E25").Select Selection.Font.Color = -16711681 Selection.Font.TintAndShade = 0 Case Else 'Komplexe Zahl Junge! End Select ThisWorkbook.Sheets(1).Cells(1, 1).Value = ThisWorkbook.Sheets(1).Cells(1, 1).Value & " " & wahl Ordner: With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = "C:\" .Title = "Ordnerauswahl" .ButtonName = "Auswahl..." .InitialView = msoFileDialogViewList If .Show = -1 Then strOrdner = .SelectedItems(1) If Right(strOrdner, 1) <> "\" Then strOrdner = strOrdner & "\" Else strOrdner = "" End If End With If strOrdner = "" Then MsgBox ("Kein Ordner gewählt!") GoTo Ordner End If DateiName = Application.InputBox("Wie soll die Datei heißen?", "Dateinamen festlegen") Datei = strOrdner & DateiName & ".pdf" ActiveWorkbook.Sheets(1).Range("A1:J34").Select Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Datei, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False ThisWorkbook.Sheets(1).Cells(1, 2).Value = bla ThisWorkbook.Sheets(1).Range("B1:J5").Select Application.ScreenUpdating = True If MsgBox("Die Datei " & Datei & " wurde gespeichert. Möchtest du das Programm beenden?", vbYesNo, "Beenden") = vbYes Then ActiveWorkbook.Save Application.DisplayAlerts = False Application.Quit End If Exit Sub ErrHandler: If MsgBox("Fehler " & Err.Number & ": " & Err.Description & vbCrLf & "Bitte kontaktieren Sie mich unter info@octooptokoppler.de!", vbCritical, "Fehler!") = vbOK Then Exit Sub End Sub Private Sub cb_trace_Click() On Error GoTo ErrHandler Dim i As Long, j As Long, Erfassung As String, Pausenzeit As Variant, aktuell As Long Unload Me Application.ScreenUpdating = False For i = 2 To ThisWorkbook.Sheets.Count If ThisWorkbook.Sheets(i).Name Like Year(Now) Then aktuell = ThisWorkbook.Sheets(i).Index Next If opb_urlaub.Value = True Then With UF_Urlaub .lb_urlaub.Clear .lb_krank.Clear For i = 2 To ThisWorkbook.Sheets(aktuell).UsedRange.Rows.Count If ThisWorkbook.Sheets(aktuell).Cells(i, 1).Value Like "" Then Exit For .lb_urlaub.AddItem ThisWorkbook.Sheets(aktuell).Cells(i, 1).Value .lb_krank.AddItem ThisWorkbook.Sheets(aktuell).Cells(i, 1).Value Next ThisWorkbook.Sheets(aktuell).Activate .Show End With ThisWorkbook.Sheets(1).Activate GoTo fertig End If If opb_self.Value = True Then Erfassung = tb_time.Text If opb_traced.Value = True Then Erfassung = Right(opb_traced.Caption, 5) Pausenzeit = tb_minutes.Text With ThisWorkbook.Sheets(aktuell) For i = 2 To .UsedRange.Rows.Count If .Cells(i, 1).Value Like Date Then 'If .Cells(i, 2).Value <> "" And .Cells(i, 3).Value <> "" And .Cells(i, 4).Value <> "" Then GoTo BreakUp If .Cells(i, 2).Value <> "" Then .Cells(i, 3).Value = Erfassung .Cells(i, 4).Value = Pausenzeit Exit For Else .Cells(i, 2).Value = Erfassung Exit For End If End If Next i End With fertig: If MsgBox("Möchtest du das Programm beenden?", vbYesNo, "Beenden") = vbYes Then Application.ScreenUpdating = True ActiveWorkbook.Save Application.DisplayAlerts = False Application.Quit End If Exit Sub ErrHandler: If MsgBox("Fehler " & Err.Number & ": " & Err.Description & vbCrLf & "Bitte kontaktieren Sie mich unter info@octooptokoppler.de!", vbCritical, "Fehler!") = vbOK Then Exit Sub End Sub Private Sub opb_self_Click() tb_time.Enabled = True UF_Begin.Repaint End Sub Public Sub opb_traced_Click() tb_time.Enabled = False UF_Begin.Repaint End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) ' Damit mit X nicht geschloßen werden kann If CloseMode = 0 Then If MsgBox("Achtung! Das Schließen dieses Fensters bewirkt, dass keine Daten eingetragen werden. Bist Du dir sicher?", vbYesNo, "Abbruch") = vbYes Then Exit Sub Else Cancel = 1 End If End If End Sub Private Sub cb_goedit_Click() Dim i As Long, j As Long, k As Long, l As Long, auswahl As Long, z As Long, dreifünf As Double On Error GoTo ErrHandler If opb_edit.Value = False And opb_show.Value = False Then MsgBox "Bitte wähle eine Option!" UF_Make.Repaint Exit Sub End If If opb_edit.Value = True Then Unload Me Exit Sub End If If opb_show.Value = True Then If UF_Make.ComboBox1.ListIndex < 0 Then MsgBox "Bitte wähle ein Jahr aus!" UF_Make.Repaint Exit Sub End If ThisWorkbook.Sheets(1).Activate auswahl = UF_Make.ComboBox1.ListIndex Unload Me ThisWorkbook.Sheets(1).Range("G34:J34").ClearContents ThisWorkbook.Sheets(1).Range("G34:J34").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone Selection.Borders(xlEdgeLeft).LineStyle = xlNone Selection.Borders(xlEdgeTop).LineStyle = xlNone Selection.Borders(xlEdgeBottom).LineStyle = xlNone Selection.Borders(xlEdgeRight).LineStyle = xlNone Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone ThisWorkbook.Sheets(1).Range("G7:J33").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With Application.DisplayAlerts = False ActiveWorkbook.Save With ThisWorkbook .Sheets(1).Cells(22, 4).Value = 0 .Sheets(1).Cells(26, 4).Value = 0 .Sheets(1).Cells(30, 4).Value = 0 .Sheets(1).Range("C8:E19").ClearContents .Sheets(1).Range("H8:H33").ClearContents .Sheets(1).Range("J8:J33").ClearContents For i = 2 To .Sheets(aushwahl + 2).UsedRange.Rows.Count 'Krankheits- und Urlaubstage sowie Gesamtüberstunden zählen If .Sheets(auswahl + 2).Cells(i, 5).Value = 0 Then Exit For If .Sheets(auswahl + 2).Cells(i, 6).Value Like "Krank" Then .Sheets(1).Cells(26, 4).Value = .Sheets(1).Cells(26, 4).Value + 1 If .Sheets(auswahl + 2).Cells(i, 6).Value Like "Urlaub" Then .Sheets(1).Cells(30, 4).Value = .Sheets(1).Cells(30, 4).Value + 1 .Sheets(1).Cells(22, 4).Value = .Sheets(1).Cells(22, 4).Value + (.Sheets(auswahl + 2).Cells(i, 5) - 8) Next For j = 1 To 12 'Arbeitszeiten nach Monaten k = 0 For i = 2 To .Sheets(auswahl + 2).UsedRange.Rows.Count If .Sheets(auswahl + 2).Cells(i, 5).Value = 0 Then Exit For If Month(.Sheets(auswahl + 2).Cells(i, 1).Value) Like Monat(.Sheets(1).Cells(j + 7, 2).Value) Then .Sheets(1).Cells(j + 7, 3).Value = .Sheets(1).Cells(j + 7, 3).Value + .Sheets(auswahl + 2).Cells(i, 5).Value k = k + 1 If Month(.Sheets(auswahl + 2).Cells(i + 1, 1).Value) Like Monat(.Sheets(1).Cells(j + 8, 2).Value) Then Exit For End If Next i .Sheets(1).Cells(j + 7, 4).Value = .Sheets(1).Cells(j + 7, 3).Value - (8 * k) Next j For i = 8 To 33 'Arbeitszeiten nach Kalenderwochen k = 0 l = 0 For j = 2 To .Sheets(auswahl + 2).UsedRange.Rows.Count If .Sheets(auswahl + 2).Cells(j, 5).Value = 0 Then Exit For If .Sheets(auswahl + 2).Cells(j, 1).Formula = "" Then Exit For 'Abbruchbedingung 'Kalenderwochen linke Spalte If KW_DIN(.Sheets(auswahl + 2).Cells(j, 1).Formula) Like Right(.Sheets(1).Cells(i, 7).Value, 2) Then .Sheets(1).Cells(i, 8).Value = .Sheets(1).Cells(i, 8).Value + .Sheets(auswahl + 2).Cells(j, 5).Value k = k + 1 End If 'Kalenderwochen rechte Spalte If KW_DIN(.Sheets(auswahl + 2).Cells(j, 1).Formula) Like Right(.Sheets(1).Cells(i, 9).Value, 2) Then .Sheets(1).Cells(i, 10).Value = .Sheets(1).Cells(i, 10).Value + .Sheets(auswahl + 2).Cells(j, 5).Value l = l + 1 End If Next j 'Überstunden zu den Arbeitszeiten nach KW addieren .Sheets(1).Cells(i, 8).Value = .Sheets(1).Cells(i, 8).Value + (.Sheets(1).Cells(i, 8).Value - (k * 8)) .Sheets(1).Cells(i, 10).Value = .Sheets(1).Cells(i, 10).Value + (.Sheets(1).Cells(i, 10).Value - (l * 8)) Next i dreifünf = 0 z = 0 For i = 2 To .Sheets(auswahl + 2).UsedRange.Rows.Count '53. KW abfragen und zählen If .Sheets(auswahl + 2).Cells(j, 5).Value = 0 Then Exit For If .Sheets(auswahl + 2).Cells(i, 1).Value Like "" Then Exit For If KW_DIN(.Sheets(auswahl + 2).Cells(i, 1).Formula) = 53 Then '53. KW abfragen dreifünf = dreifünf + .Sheets(auswahl + 2).Cells(i, 5).Value z = z + 1 End If Next End With Select Case ThisWorkbook.Sheets(1).Cells(22, 4).Value Case Is > 0 ThisWorkbook.Sheets(1).Range("D22:E25").Select Selection.Font.ThemeColor = xlThemeColorAccent6 Selection.Font.TintAndShade = -0.499984740745262 Case Is < 0 ThisWorkbook.Sheets(1).Range("D22:E25").Select Selection.Font.Color = -16776961 Selection.Font.TintAndShade = 0 Case Is = 0 ThisWorkbook.Sheets(1).Range("D22:E25").Select Selection.Font.Color = -16711681 Selection.Font.TintAndShade = 0 Case Else 'Komplexe Zahl Junge! End Select If dreifünf > 0 Or z > 0 Then ThisWorkbook.Sheets(1).Cells(34, 7).Value = "KW53" ThisWorkbook.Sheets(1).Cells(34, 9).Value = dreifünf + (dreifünf - (z * 8)) ThisWorkbook.Sheets(1).Range("G34:J34").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With Selection.Borders(xlInsideHorizontal).LineStyle = xlNone ThisWorkbook.Sheets(1).Range("B1:J5").Select End If End If Exit Sub ErrHandler: If MsgBox("Fehler " & Err.Number & ": " & Err.Description & vbCrLf & "Bitte kontaktieren Sie mich unter info@octooptokoppler.de!", vbCritical, "Fehler!") = vbOK Then Exit Sub End Sub Private Sub cb_make_Click() 'Prozedur zum generieren neuer Tabellenblätter Dim ThisYear As Long, i As Long, j As Long, k As Long Dim datum As Variant, ersterMärz As Variant Dim Jahre As Long On Error GoTo ErrHandler Application.ScreenUpdating = False If tb_years.Text = "" Then MsgBox "Es wurde keine Eingabe gemacht!" UF_Make.Repaint Exit Sub Else Jahre = tb_years.Text End If With ThisWorkbook For i = .Sheets.Count + 1 To .Sheets.Count + Jahre ThisYear = .Sheets(i - 1).Name + 1 datum = "1/1/" & ThisYear ersterMärz = "1/3/" & ThisYear .Sheets.Add After:=.Sheets(.Sheets.Count) .Sheets(.Sheets.Count).Activate .Sheets(.Sheets.Count).Name = ThisYear .Sheets(.Sheets.Count).Cells(1, 1).Value = "Datum" .Sheets(.Sheets.Count).Cells(1, 2).Value = "Beginn" .Sheets(.Sheets.Count).Cells(1, 3).Value = "Ende" .Sheets(.Sheets.Count).Cells(1, 4).Value = "Pause" .Sheets(.Sheets.Count).Cells(1, 5).Value = "Arbeitszeit" .Sheets(.Sheets.Count).Cells(1, 6).Value = "Bemerkung" .Sheets(.Sheets.Count).Range("A1:F1").Font.Bold = True k = 2 Do Until Right(datum, 4) > ThisYear Select Case Weekday(datum, vbMonday) Case 1, 2, 3, 4, 5 .Sheets(.Sheets.Count).Cells(k, 1).Select Selection.NumberFormat = "[$-F800]dddd, mmmm dd, yyyy" .Sheets(.Sheets.Count).Cells(k, 1).FormulaR1C1 = datum .Sheets(.Sheets.Count).Cells(k, 2).Select Selection.NumberFormat = "h:mm;@" .Sheets(.Sheets.Count).Cells(k, 3).Select Selection.NumberFormat = "h:mm;@" .Sheets(.Sheets.Count).Cells(k, 4).Select Selection.NumberFormat = "0" .Sheets(.Sheets.Count).Cells(k, 5).Select Selection.NumberFormat = "0.00" ActiveCell.FormulaR1C1Local = "=WENNFEHLER(STUNDE(ZS(-2)-ZS(-3)-ZEIT(0;ZS(-1);0))+((MINUTE(ZS(-2)-ZS(-3)-ZEIT(0;ZS(-1);0))/100)*100/60);0)" .Sheets(.Sheets.Count).Cells(k, 6).Select Selection.NumberFormat = "@" 'Feste und bewegliche gesetzliche Feiertage eintragen (natürlich nur die säschsischen) If Left(datum, 4) Like "1/1/" Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Neujahr" If Left(datum, 6) Like "01.05." Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Tag der Arbeit" If Left(datum, 6) Like "03.10." Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Tag der Deutschen Einheit" If Left(datum, 6) Like "31.10." Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Reformationstag" If Left(datum, 6) Like "25.12." Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "1. Weihnachtsfeiertag" If Left(datum, 6) Like "26.12." Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "2. Weihnachtsfeiertag" 'Bewegliche Feiertage eintragen If Left(DateAdd("d", Ostersonntag(ThisYear) - 3, ersterMärz), 6) Like Left(datum, 6) Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Karfreitag" If Left(DateAdd("d", Ostersonntag(ThisYear), ersterMärz), 6) Like Left(datum, 6) Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Ostermontag" If Left(DateAdd("d", Ostersonntag(ThisYear) + 38, ersterMärz), 6) Like Left(datum, 6) Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Himmelfahrt" If Left(DateAdd("d", Ostersonntag(ThisYear) + 49, ersterMärz), 6) Like Left(datum, 6) Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Pfingstmontag" If .Sheets(.Sheets.Count).Cells(k, 1).Value Like Bettag(ThisYear) Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Buß- und Bettag" If IstFeiertag(datum) = True Then .Sheets(.Sheets.Count).Cells(k, 2).Value = "0:00" .Sheets(.Sheets.Count).Cells(k, 3).Value = "0:00" .Sheets(.Sheets.Count).Cells(k, 4).Value = "0" .Sheets(.Sheets.Count).Cells(k, 5).Value = "8" End If k = k + 1 Case Else End Select datum = DateAdd("d", 1, datum) Loop Next i .Sheets(.Sheets.Count).Columns("A:A").EntireColumn.AutoFit .Sheets(.Sheets.Count).Columns("F:F").EntireColumn.AutoFit .Sheets(.Sheets.Count).Range("A1").Select ActiveWindow.SplitColumn = 0 ActiveWindow.SplitRow = 1 ActiveWindow.FreezePanes = True End With Unload Me Application.ScreenUpdating = True Exit Sub ErrHandler: If MsgBox("Fehler " & Err.Number & ": " & Err.Description & vbCrLf & "Bitte kontaktieren Sie mich unter info@octooptokoppler.de!", vbCritical, "Fehler!") = vbOK Then Exit Sub End Sub Private Sub cb_new_Click() With UF_Make .Frame1.Visible = True .Frame2.Visible = False .cb_time.Enabled = True .cb_new.Enabled = False End With End Sub Private Sub cb_time_Click() With UF_Make .Frame1.Visible = False .Frame2.Visible = True .cb_time.Enabled = False .cb_new.Enabled = True .ComboBox1.Enabled = False End With End Sub Private Sub opb_edit_Click() UF_Make.opb_show.Value = False UF_Make.ComboBox1.Enabled = False End Sub Private Sub opb_show_Click() UF_Make.opb_edit.Value = False UF_Make.ComboBox1.Enabled = True End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) ' Damit mit X nicht geschloßen werden kann If CloseMode = 0 Then If MsgBox("Das Abbrechen dieses Fensters ist unzulässig!", vbExclamation, "Abbruch") = vbYes Then Else Cancel = 1 End If End If End Sub Sub tb_years_Change() If Not IsNumeric(TextBox1) Then MsgBox "Nur numerische Eingaben erlaubt!", _ vbInformation + vbOKOnly, "Hinweis" TextBox1 = "" & Left(TextBox1, Len(TextBox1) - 1) End If End Sub Private Sub cb_ok_Click() Dim i As Long, j As Long On Error GoTo ErrHandler If lb_urlaub.ListIndex > -1 Or lb_krank.ListIndex > -1 Then For j = 0 To lb_urlaub.ListCount - 1 If lb_urlaub.Selected(j) Then For i = 2 To ThisWorkbook.ActiveSheet.UsedRange.Rows.Count If ThisWorkbook.ActiveSheet.Cells(i, 1).Value Like lb_urlaub.List(j) Then ThisWorkbook.ActiveSheet.Cells(i, 2).Value = "0:00" ThisWorkbook.ActiveSheet.Cells(i, 3).Value = "0:00" ThisWorkbook.ActiveSheet.Cells(i, 4).Value = "0" ThisWorkbook.ActiveSheet.Cells(i, 5).Value = "8" ThisWorkbook.ActiveSheet.Cells(i, 6).Value = "Urlaub" Exit For End If Next i ElseIf lb_krank.Selected(j) Then For i = 2 To ThisWorkbook.ActiveSheet.UsedRange.Rows.Count If ThisWorkbook.ActiveSheet.Cells(i, 1).Value Like lb_krank.List(j) Then ThisWorkbook.ActiveSheet.Cells(i, 2).Value = "0:00" ThisWorkbook.ActiveSheet.Cells(i, 3).Value = "0:00" ThisWorkbook.ActiveSheet.Cells(i, 4).Value = "0" ThisWorkbook.ActiveSheet.Cells(i, 5).Value = "8" ThisWorkbook.ActiveSheet.Cells(i, 6).Value = "Krank" Exit For End If Next i End If Next j Else MsgBox "Es muss mindestens ein Datum gewählt werden!" UF_Urlaub.Repaint Exit Sub End If Unload Me Exit Sub ErrHandler: If MsgBox("Fehler " & Err.Number & ": " & Err.Description & vbCrLf & "Bitte kontaktieren Sie mich unter info@octooptokoppler.de!", vbCritical, "Fehler!") = vbOK Then Exit Sub End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) ' Damit mit X nicht geschloßen werden kann If CloseMode = 0 Then If MsgBox("Achtung! Das Schließen dieses Fensters bewirkt, dass keine Daten eingetragen werden. Bist Du dir sicher?", vbYesNo, "Abbruch") = vbYes Then Exit Sub Else Cancel = 1 End If End If End Sub Public Sub CommandButton1_Click() On Error GoTo ErrHandler If ComboBox1.ListIndex < 0 Then MsgBox "Es wurde kein Jahr gewählt!" UF_Year.Repaint Exit Sub Else ThisWorkbook.Sheets(1).Cells(100, 1).Value = ComboBox1.List(ComboBox1.ListIndex) ThisWorkbook.Sheets(1).Cells(100, 2).Value = ComboBox1.ListIndex Unload Me End If Exit Sub ErrHandler: If MsgBox("Fehler " & Err.Number & ": " & Err.Description & vbCrLf & "Bitte kontaktieren Sie mich unter info@octooptokoppler.de!", vbCritical, "Fehler!") = vbOK Then Exit Sub End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) ' Damit mit X nicht geschloßen werden kann If CloseMode = 0 Then If MsgBox("Das Abbrechen dieses Fensters ist unzulässig!", vbExclamation, "Abbruch") = vbYes Then Else Cancel = 1 End If End If End Sub Public Function KW_DIN(datum) 'von Christoph Kremer, Aachen 'Berechnt die KW nach ISO 8601 Dim t& t = DateSerial(Year(datum + (8 - Weekday(datum)) Mod 7 - 3), 1, 1) KW_DIN = (datum - t - 3 + (Weekday(t) + 1) Mod 7) \ 7 + 1 End Function Public Function Monat(Name) 'gibt die Ziffer des entsprechenden Monats aus Select Case Name Case "Januar" Monat = 1 Case "Februar" Monat = 2 Case "März" Monat = 3 Case "April" Monat = 4 Case "Mai" Monat = 5 Case "Juni" Monat = 6 Case "Juli" Monat = 7 Case "August" Monat = 8 Case "September" Monat = 9 Case "Oktober" Monat = 10 Case "November" Monat = 11 Case "Dezember" Monat = 12 Case Else Monat = 0 End Select End Function Public Function Ostersonntag(jahr) 'https://de.wikipedia.org/wiki/Gaußsche_Osterformel#Eine_ergänzte_Osterformel k = jahr \ 100 m = 15 + (3 * k + 3) \ 4 - (8 * k + 13) \ 25 s = 2 - (3 * k + 3) \ 4 a = jahr Mod 19 d = (19 * a + m) Mod 30 r = (d + a \ 11) \ 29 OG = 21 + d - r SZ = 7 - (jahr + jahr \ 4 + s) Mod 7 OE = 7 - (OG - SZ) Mod 7 Ostersonntag = OG + OE End Function Public Function Bettag(jahr) 'Der Buß- und Bettag ist als der letzte Mittwoch vor dem 23. November definiert. 'Falls der 23. November ein Mittwoch ist, so ist der Buß- und Bettag am 16. November. 'Die Ausgabe erfolgt als vollständiges Datum. hilf = "23.11." & jahr If Weekday(hilf, vbMonday) = 3 Then Bettag = DateAdd("d", -7, hilf) Else Do hilf = DateAdd("d", -1, hilf) Loop Until Weekday(hilf, vbMonday) = 3 Bettag = hilf End If End Function Public Function IstFeiertag(datum) As Boolean 'Prüft das Datum, ob es ein gesetzlicher Feiertag ist und gibt einen boolschen Wert zurück. Select Case Left(datum, 6) Case "01.01." IstFeiertag = True Case "01.05." IstFeiertag = True Case "03.10." IstFeiertag = True Case "31.10." IstFeiertag = True Case "25.12." IstFeiertag = True Case "26.12." IstFeiertag = True Case Left(Bettag(Right(datum, 4)), 6) IstFeiertag = True Case Left(DateAdd("d", Ostersonntag(Right(datum, 4)), "01.03." & Right(datum, 4)), 6) IstFeiertag = True Case Left(DateAdd("d", Ostersonntag(Right(datum, 4)) - 3, "01.03." & Right(datum, 4)), 6) IstFeiertag = True Case Left(DateAdd("d", Ostersonntag(Right(datum, 4) + 38), "01.03." & Right(datum, 4)), 6) IstFeiertag = True Case Left(DateAdd("d", Ostersonntag(Right(datum, 4) + 49), "01.03." & Right(datum, 4)), 6) IstFeiertag = True Case Else IstFeiertag = False End Select End Function Public Sub newSheet() 'Prozedur zum generieren neuer Tabellenblätter Dim i As Long, j As Long, k As Long Dim datum As Variant, ersterMärz As Variant Dim Jahre As Long On Error GoTo ErrHandler Application.ScreenUpdating = False With ThisWorkbook For i = .Sheets.Count + 1 To .Sheets.Count + Jahre Year(Date) = .Sheets(i - 1).Name + 1 datum = "1/1/" & ThisYear ersterMärz = "1/3/" & ThisYear .Sheets.Add After:=.Sheets(.Sheets.Count) .Sheets(.Sheets.Count).Activate .Sheets(.Sheets.Count).Name = ThisYear .Sheets(.Sheets.Count).Cells(1, 1).Value = "Datum" .Sheets(.Sheets.Count).Cells(1, 2).Value = "Beginn" .Sheets(.Sheets.Count).Cells(1, 3).Value = "Ende" .Sheets(.Sheets.Count).Cells(1, 4).Value = "Pause" .Sheets(.Sheets.Count).Cells(1, 5).Value = "Arbeitszeit" .Sheets(.Sheets.Count).Cells(1, 6).Value = "Bemerkung" .Sheets(.Sheets.Count).Range("A1:F1").Font.Bold = True k = 2 Do Until Right(datum, 4) > ThisYear Select Case Weekday(datum, vbMonday) Case 1, 2, 3, 4, 5 .Sheets(.Sheets.Count).Cells(k, 1).Select Selection.NumberFormat = "[$-F800]dddd, mmmm dd, yyyy" .Sheets(.Sheets.Count).Cells(k, 1).FormulaR1C1 = datum .Sheets(.Sheets.Count).Cells(k, 2).Select Selection.NumberFormat = "h:mm;@" .Sheets(.Sheets.Count).Cells(k, 3).Select Selection.NumberFormat = "h:mm;@" .Sheets(.Sheets.Count).Cells(k, 4).Select Selection.NumberFormat = "0" .Sheets(.Sheets.Count).Cells(k, 5).Select Selection.NumberFormat = "0.00" ActiveCell.FormulaR1C1Local = "=WENNFEHLER(STUNDE(ZS(-2)-ZS(-3)-ZEIT(0;ZS(-1);0))+((MINUTE(ZS(-2)-ZS(-3)-ZEIT(0;ZS(-1);0))/100)*100/60);0)" .Sheets(.Sheets.Count).Cells(k, 6).Select Selection.NumberFormat = "@" 'Feste und bewegliche gesetzliche Feiertage eintragen (natürlich nur die säschsischen) If Left(datum, 4) Like "1/1/" Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Neujahr" If Left(datum, 6) Like "01.05." Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Tag der Arbeit" If Left(datum, 6) Like "03.10." Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Tag der Deutschen Einheit" If Left(datum, 6) Like "31.10." Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Reformationstag" If Left(datum, 6) Like "25.12." Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "1. Weihnachtsfeiertag" If Left(datum, 6) Like "26.12." Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "2. Weihnachtsfeiertag" 'Bewegliche Feiertage eintragen If Left(DateAdd("d", Ostersonntag(ThisYear) - 3, ersterMärz), 6) Like Left(datum, 6) Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Karfreitag" If Left(DateAdd("d", Ostersonntag(ThisYear), ersterMärz), 6) Like Left(datum, 6) Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Ostermontag" If Left(DateAdd("d", Ostersonntag(ThisYear) + 38, ersterMärz), 6) Like Left(datum, 6) Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Himmelfahrt" If Left(DateAdd("d", Ostersonntag(ThisYear) + 49, ersterMärz), 6) Like Left(datum, 6) Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Pfingstmontag" If .Sheets(.Sheets.Count).Cells(k, 1).Value Like Bettag(ThisYear) Then .Sheets(.Sheets.Count).Cells(k, 6).Value = "Buß- und Bettag" If IstFeiertag(datum) = True Then .Sheets(.Sheets.Count).Cells(k, 2).Value = "0:00" .Sheets(.Sheets.Count).Cells(k, 3).Value = "0:00" .Sheets(.Sheets.Count).Cells(k, 4).Value = "0" .Sheets(.Sheets.Count).Cells(k, 5).Value = "8" End If k = k + 1 Case Else End Select datum = DateAdd("d", 1, datum) Loop Next i .Sheets(.Sheets.Count).Columns("A:A").EntireColumn.AutoFit .Sheets(.Sheets.Count).Columns("F:F").EntireColumn.AutoFit .Sheets(.Sheets.Count).Range("A1").Select ActiveWindow.SplitColumn = 0 ActiveWindow.SplitRow = 1 ActiveWindow.FreezePanes = True End With Application.ScreenUpdating = True End Sub