Jahresplan auf Monatsplan runterbrechen
11.01.2022 14:59:57
Bernd
Ich hab ein Jahresplan im Reiter "Dienst"
dieser soll nun aufgesplittet werden auf die Monate
Mein versuch das über eine Transponierung laufen zu lassen ist schief gelaufen
an den Reitern von "Dienst" und den jeweiligen Monat kann leider nichts geändert werden.
Die Monate werden wieder von einer anderen Tabelle zur Auswertung abgefragt. Aus diesem Grund kann ich dort nichts änderen.
Habt Ihr ein Vorschlag ?
Für die Datumsberechnung des jeweiligen Monats habe ich das hier verwendet
jedoch hab ich hier ein Fehler und finde diesen nicht
jedoch funktioniert sie auf Arbeit.
Sub wrapper_make_time()
Call make_time(Sheets("Start").Range("F4").Text)
End Sub
Sub make_time(year As String)
Dim month, bebefore, before, curr_date, week_day As String
Dim curr As Range
Dim Feiertagsprüfung As Date
ActiveSheet.Unprotect
month = ActiveSheet.Range("I8").Text
curr_date = Format("01." & month & "." & year, "dd.mm.yyyy")
For i = 18 To 59
bebefor = ActiveSheet.Cells(i - 2, 2).Text
befor = ActiveSheet.Cells(i - 1, 2).Text
Set curr = ActiveSheet.Cells(i, 2)
week_day = ActiveSheet.Cells(i, 3).Text
If Len(before) > 1 And Len(week_day) > 1 Then
curr_date = Int(before) + 1 & Right(curr_date, 8)
If test_end_date(curr_date) Then
Exit Sub
End If
curr = Format(curr_date, "dd")
ElseIf Len(bebefore) > 1 And Len(week_day) > 1 Then
curr_date = Int(bebefore) + 1 & Right(curr_date, 8)
If test_end_date(curr_date) Then
Exit Sub
End If
curr = Format(curr_date, "dd")
ElseIf week_day = Format(curr_date, "ddd") Then
curr = Format(curr_date, "dd")
End If
'Feiertagsprüfung = curr_date
'If WorksheetFunktion.CountIf(Sheets("Feiertage").Range("C:C"), Feiertagsprüfung) > 0 Then
' With ActiveSheet.Cells(i, 2).Font
' .Color = -16763905
' .TintAndShade = 0
' End With
'End If
Next i
End Sub
Function test_end_date(ByVal curr_date As String) As Integer
Dim my_test As Date
Dim res As Integer
res = 0
On Error GoTo err_month:
my_test = Format(curr_date, "dd.mm.yyyy")
If Day(my_test) > Day(Application.WorksheetFunktion.EoMonth(my_test, 0)) Then
res = 1
End If
test_end_date = res
Exit Function
err_month:
test_end_date = 1
End Function