Sub Kalender()
'toewijzen variabelen
Dim yr As Integer, WS As Worksheet, SDate As Date, wks As Integer, i As Integer, leap As String, jaar As Integer
On Error Resume Next
'opgeven jaartal
yr = InputBox(Prompt:="Geef jaartal op", Default:=Year(Date))
On Error GoTo 0
If yr = 0 Then Exit Sub
If Not IsDate(DateSerial(yr, 1, 1)) Then Exit Sub
Application.ScreenUpdating = False
'toewijzen jaartal, bepalen schrikkel jaar, aantal weken bepalen
SDate = DateSerial(yr, 1, 1)
jaar = Worksheets("totaal").Range("b1")
Worksheets("totaal").Range("b1").FormulaR1C1 = yr
leap = Worksheets("totaal").Range("l6")
If leap = "ja" Then GoTo schrikkel
If Weekday(SDate) = 5 Then wks = 53 Else wks = 52
Worksheets("totaal").Range("i1").FormulaR1C1 = wks
'begin van week 1 bepalen
If Weekday(SDate) <= 5 Then GoTo doloop1 Else GoTo doloop2
'week 1 begint nog in vorig jaar en het jaar is geen schrikkeljaar
doloop1:
Do Until Weekday(SDate, vbMonday) = 1
SDate = SDate - 1
Loop
Worksheets("totaal").Range("A3:c3") = Array("Week nummer", "Startdatum week", "Einddatum week")
Worksheets("totaal").Range("A4:C4") = Array(1, SDate, SDate + 6)
For i = 2 To wks
Worksheets("totaal").Range("A3:C3").Offset(i, 0) = Array(i, SDate + (7 * (i - 1)), SDate + (7 * (i - 1)) + 6)
Next i
If wks = 52 Then Worksheets("totaal").Range("a56:c56").FormulaR1C1 = ""
Application.ScreenUpdating = True
GoTo einde
'week 1 begint in nieuwe jaar en het jaar is geen schrikkeljaar
doloop2:
Do Until Weekday(SDate, vbMonday) = 1
SDate = SDate + 1
Loop
Worksheets("totaal").Range("A3:c3") = Array("Week nummer", "Startdatum week", "Einddatum week")
Worksheets("totaal").Range("A4:C4") = Array(1, SDate, SDate + 6)
For i = 2 To wks
Worksheets("totaal").Range("A3:C3").Offset(i, 0) = Array(i, SDate + (7 * (i - 1)), SDate + (7 * (i - 1)) + 6)
Next i
If wks = 52 Then Worksheets("totaal").Range("a56:c56").FormulaR1C1 = ""
Application.ScreenUpdating = True
GoTo einde
schrikkel:
'begin van week 1 bepalen
If Weekday(SDate) = 5 Or Weekday(SDate) = 4 Then wks = 53 Else wks = 52
Worksheets("totaal").Range("i1").FormulaR1C1 = wks
If Weekday(SDate) <= 5 Then GoTo doloop3 Else GoTo doloop4
'week 1 begint in het vorige jaar en het jaar is een schrikkeljaar
doloop3:
Do Until Weekday(SDate, vbMonday) = 1
SDate = SDate - 1
Loop
Worksheets("totaal").Range("A3:c3") = Array("Week nummer", "Startdatum week", "Einddatum week")
Worksheets("totaal").Range("A4:C4") = Array(1, SDate, SDate + 6)
For i = 2 To wks
Worksheets("totaal").Range("A3:C3").Offset(i, 0) = Array(i, SDate + (7 * (i - 1)), SDate + (7 * (i - 1)) + 6)
Next i
If wks = 52 Then Worksheets("totaal").Range("a56:c56").FormulaR1C1 = ""
Application.ScreenUpdating = True
GoTo einde
'week 1 begint in het nieuwe jaar en het jaar is een schrikkeljaar
doloop4:
Do Until Weekday(SDate, vbMonday) = 1
SDate = SDate + 1
Loop
Worksheets("totaal").Range("A3:c3") = Array("Week nummer", "Startdatum week", "Einddatum week")
Worksheets("totaal").Range("A4:C4") = Array(1, SDate, SDate + 6)
For i = 2 To wks
Worksheets("totaal").Range("A3:C3").Offset(i, 0) = Array(i, SDate + (7 * (i - 1)), SDate + (7 * (i - 1)) + 6)
Next i
If wks = 52 Then Worksheets("totaal").Range("a56:c56").FormulaR1C1 = ""
Application.ScreenUpdating = True
GoTo einde
einde:
End Sub
now there is another program being run after the calendar has been made, but that is of no importance.