Sub monatrapport_neut_temp2()
Dim Zeile As Long
Dim ZeileMax As Long
Dim n As Long
Dim kopf As Long
Dim monat As Integer
Dim blatt As Object
Dim BlattName As String
Dim bolFlg As Boolean
monat = InputBox("Bitte gewünschten Monat eingeben")
With Worksheets("Dienst")
ZeileMax = .UsedRange.Rows.Count
End With
BlattName = MonthName(monat)
For Each blatt In Sheets
If blatt.Name = BlattName Then bolFlg = True
Next blatt
If bolFlg = False Then
With ThisWorkbook
.Sheets.Add after:=Sheets(Worksheets.Count)
.ActiveSheet.Name = (BlattName)
End With
End If
With Worksheets(BlattName)
Worksheets(BlattName).UsedRange.ClearContents
.Columns("a:z").NumberFormat = "[h]:mm"
.Range("a1:z5000").Interior.Color = vbWhite
.Range("a1:z5000").Borders.LineStyle = -4142
.Range("A1:z5000").Font.Name = "Calibri"
.Range("a1:z5000").Font.Bold = False
.Range("a1:z5000").Font.Size = 10
kopf = 9
n = 10
zeilex = 0
.Range("a" & kopf - 3).Value = "Name"
.Range("b" & kopf - 3).Value = Worksheets("Dienst").Range("b3").Value
.Range("a" & kopf - 2).Value = "Monat"
.Range("b" & kopf - 2) = MonthName(monat)
.Range("d" & kopf - 2).Value = "Jahr"
.Range("e" & kopf - 2).Value = "2021"
.Range("e" & kopf - 2).NumberFormat = "0000"
End With
With Worksheets(BlattName).Range("A" & kopf, "a" & kopf)
.Value = "Dienst"
.Font.Size = 13
.Font.Bold = True
.Font.ColorIndex = 1
End With
With Worksheets(BlattName).Range("d" & kopf, "d" & kopf)
.Value = "Beginn"
.Font.Size = 8
.Font.Bold = True
.Font.ColorIndex = 1
End With
With Worksheets(BlattName).Range("e" & kopf, "e" & kopf)
.Value = "Ende"
.Font.Size = 8
.Font.Bold = True
.Font.ColorIndex = 1
End With
With Worksheets(BlattName).Range("f" & kopf, "f" & kopf)
.Value = "Pause"
.Font.Size = 8
.Font.Bold = True
.Font.ColorIndex = 1
End With
With Worksheets(BlattName).Range("g" & kopf, "g" & kopf)
.Value = "Stunden"
.Font.Size = 8
.Font.Bold = True
.Font.ColorIndex = 1
End With
With Worksheets(BlattName).Range("h" & kopf, "h" & kopf)
.Value = "Nacht"
.Font.Size = 8
.Font.Bold = True
.Font.ColorIndex = 1
End With
With Worksheets(BlattName).Range("i" & kopf, "i" & kopf)
.Value = "Sonntag"
.Font.Size = 8
.Font.Bold = True
.Font.ColorIndex = 1
End With
With Worksheets("Dienst")
For Zeile = 8 To ZeileMax
If Month(.Cells(Zeile, 1).Value) = monat Then
.Range("a" & Zeile, "i" & Zeile).Copy Destination:=Worksheets(BlattName).Rows(n)
n = n + 1
End If
Next Zeile
End With
End Sub